diff options
Diffstat (limited to 'lisp/emacs-lisp')
80 files changed, 18729 insertions, 10728 deletions
diff --git a/lisp/emacs-lisp/.gitignore b/lisp/emacs-lisp/.gitignore index 88830a1c6e8..133e79e817a 100644 --- a/lisp/emacs-lisp/.gitignore +++ b/lisp/emacs-lisp/.gitignore @@ -1,3 +1,2 @@ !*-loaddefs.el -# arch-tag: d0a60bce-b886-4817-b4c3-9a81ba0308bc diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 19d50d10f04..eb95fae2339 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1,12 +1,12 @@ -;;; advice.el --- an overloading mechanism for Emacs Lisp functions +;;; advice.el --- An overloading mechanism for Emacs Lisp functions -;; Copyright (C) 1993, 1994, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1993-1994, 2000-2013 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: FSF ;; Created: 12 Dec 1992 ;; Keywords: extensions, lisp, tools +;; Package: emacs ;; This file is part of GNU Emacs. @@ -31,10 +31,6 @@ ;;; Commentary: -;; NOTE: This documentation is slightly out of date. In particular, all the -;; references to Emacs-18 are obsolete now, because it is not any longer -;; supported by this version of Advice. - ;; Advice is documented in the Emacs Lisp Manual. ;; @ Introduction: @@ -83,21 +79,10 @@ ;; - 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 `";; @+"'). +;; You can use `outline-mode' to help you read this documentation (set +;; `outline-regexp' to `";; @+"'). ;; ;; The four major sections of this file are: ;; @@ -111,9 +96,6 @@ ;; @ Restrictions: ;; =============== -;; - This version of Advice only works for Emacs 19.26 and later. It uses -;; new versions of the built-in functions `fset/defalias' which are not -;; yet available in Lucid Emacs, hence, it won't work there. ;; - Advised functions/macros/subrs will only exhibit their advised behavior ;; when they are invoked via their function cell. This means that advice will ;; not work for the following: @@ -229,13 +211,8 @@ ;; @@ Terminology: ;; =============== -;; - Emacs, Emacs-19: Emacs as released by the GNU Project -;; - Lemacs: Lucid's version of Emacs with major version 19 -;; - v18: Any Emacs with major version 18 or built as an extension to that -;; (such as Epoch) -;; - v19: Any Emacs with major version 19 -;; - jwz: Jamie Zawinski - former keeper of Lemacs and creator of the optimizing -;; byte-compiler used in v19s. +;; - Emacs: Emacs as released by the GNU Project +;; - jwz: Jamie Zawinski - creator of the byte-compiler used in v19s. ;; - Advice: The name of this package. ;; - advices: Short for "pieces of advice". @@ -294,8 +271,7 @@ ;; 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). +;; actually compiled. ;; An optional <documentation-string> can be supplied to document the advice. ;; On call of the `documentation' function it will be combined with the @@ -348,10 +324,7 @@ ;; 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. +;; more portable argument access macros are also provided (see below). ;; <advised-docstring> is an optional, special documentation string which will ;; be expanded into a proper documentation string upon call of `documentation'. @@ -402,10 +375,7 @@ ;; 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. +;; same piece of advice across different versions of Emacs. ;; As a solution to that advice provides argument list access macros that get ;; translated into the proper access forms at activation time, i.e., when the @@ -491,47 +461,15 @@ ;; @@@ 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)' +;; Because `defadvice' allows the specification of the argument list +;; of the advised function we need a mapping mechanism that maps this +;; argument list onto that of the original function. Hence SYM and +;; 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. ;; @@ Activation and deactivation: ;; =============================== @@ -591,12 +529,7 @@ ;; 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). +;; definition will be saved, and then the advice will be activated. ;; @@ Enabling/disabling pieces or sets of advice: ;; =============================================== @@ -655,12 +588,12 @@ ;; ;; (ad-activate-regexp "^ange-ftp-") ;; -;; A saver way would have been to use +;; A safer 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, but not functions that were currently inactive. All these ;; functions can also be called interactively. ;; A certain piece of advice is considered a match if its name contains a @@ -694,8 +627,8 @@ ;; @@@ 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'. +;; Automatic advice activation is enabled by default. It can be disabled with +;; `M-x ad-stop-advice' and enabled again with `M-x ad-start-advice'. ;; @@ Caching of advised definitions: ;; ================================== @@ -729,10 +662,8 @@ ;; specified as disabled) and all other currently enabled pieces of advice to ;; construct an advised definition and an identifying cache-id and makes them ;; part of the `defadvice' expansion which will then be compiled by the -;; byte-compiler (to ensure that in a v18 emacs you have to put the -;; `defadvice' inside a `defun' to get it compiled and then you have to call -;; that compiled `defun' in order to actually execute the `defadvice'). When -;; the file with the compiled, preactivating `defadvice' gets loaded the +;; byte-compiler. +;; When the file with the compiled, preactivating `defadvice' gets loaded the ;; precompiled advised definition will be cached on the advised function's ;; advice-info. When it gets activated (can be immediately on execution of the ;; `defadvice' or any time later) the cache-id gets checked against the @@ -827,8 +758,7 @@ ;; 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). +;; is to define file load hooks for files that do not provide such hooks. ;; For example, suppose you want to print a message whenever `file-x' gets ;; loaded, and suppose the last function defined in `file-x' is ;; `file-x-last-fn'. Then we can define the following advice: @@ -863,7 +793,7 @@ ;; 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. +;; currently inactive 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. @@ -883,7 +813,7 @@ ;; - 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. +;; yet activated or is currently inactive. ;; - 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 @@ -914,9 +844,6 @@ ;; @@ 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 @@ -1291,7 +1218,7 @@ ;; 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: +;; inactive functions: ;; ;; (ad-update-regexp "^fg-") ;; nil @@ -1438,8 +1365,8 @@ ;; ;; If you put a preactivating `defadvice' into a Lisp file that gets byte- ;; compiled then the constructed advised definition will get compiled by -;; the byte-compiler. For that to occur in a v18 emacs you have to put the -;; `defadvice' inside a `defun' because the v18 compiler does not compile +;; the byte-compiler. For that to occur in a v18 Emacs you had to put the +;; `defadvice' inside a `defun' because the v18 compiler did not compile ;; top-level forms other than `defun' or `defmacro', for example, ;; ;; (defun fg-defadvice-fum () @@ -1534,10 +1461,7 @@ ;; if one advises a subr such as `eval-region' which then gets redefined by ;; some package (e.g., edebug) into a function with different argument names, ;; then a piece of advice written for `eval-region' that was written with -;; the subr arguments in mind will break. Similar situations arise when one -;; switches between major Emacs versions, e.g., certain subrs in v18 are -;; functions in v19 and vice versa. Also, in v19s subr argument lists -;; are available and will be used, while they are not available in v18. +;; the subr arguments in mind will break. ;; ;; Argument access text macros allow one to access arguments of an advised ;; function in a portable way without having to worry about all these @@ -1638,7 +1562,7 @@ ;; fii ;; ;; Now we advise `fii' to use an optional second argument that controls the -;; amount of incrementation. A list following the (optional) position +;; amount of incrementing. 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? @@ -1654,41 +1578,6 @@ ;; (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 @@ -1819,7 +1708,9 @@ (provide 'advice-preload) ;; During a normal load this is a noop: (require 'advice-preload "advice.el") - +(require 'macroexp) +;; At run-time also, since ad-do-advised-functions returns code that uses it. +(require 'cl-lib) ;; @@ Variable definitions: ;; ======================== @@ -1885,54 +1776,6 @@ generates a copy of TREE." (funcall fUnCtIoN tReE)) (t tReE))) -;; this is just faster than `ad-substitute-tree': -(defun ad-copy-tree (tree) - "Return a copy of the list structure of TREE." - (cond ((consp tree) - (cons (ad-copy-tree (car tree)) - (ad-copy-tree (cdr tree)))) - (t tree))) - -(defmacro ad-dolist (varform &rest body) - "A Common-Lisp-style dolist iterator with the following syntax: - - (ad-dolist (VAR INIT-FORM [RESULT-FORM]) - BODY-FORM...) - -which will iterate over the list yielded by INIT-FORM binding VAR to the -current head at every iteration. If RESULT-FORM is supplied its value will -be returned at the end of the iteration, nil otherwise. The iteration can be -exited prematurely with `(ad-do-return [VALUE])'." - (let ((expansion - `(let ((ad-dO-vAr ,(car (cdr varform))) - ,(car varform)) - (while ad-dO-vAr - (setq ,(car varform) (car ad-dO-vAr)) - ,@body - ;;work around a backquote bug: - ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong - ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar))) - ,'(setq ad-dO-vAr (cdr ad-dO-vAr))) - ,(car (cdr (cdr varform)))))) - ;;ok, this wastes some cons cells but only during compilation: - (if (catch 'contains-return - (ad-substitute-tree - (function (lambda (subtree) - (cond ((eq (car-safe subtree) 'ad-dolist)) - ((eq (car-safe subtree) 'ad-do-return) - (throw 'contains-return t))))) - 'identity body) - nil) - `(catch 'ad-dO-eXiT ,expansion) - expansion))) - -(defmacro ad-do-return (value) - `(throw 'ad-dO-eXiT ,value)) - -(if (not (get 'ad-dolist 'lisp-indent-hook)) - (put 'ad-dolist 'lisp-indent-hook 1)) - - ;; @@ Save real definitions of subrs used by Advice: ;; ================================================= ;; Advice depends on the real, unmodified functionality of various subrs, @@ -1997,19 +1840,17 @@ exited prematurely with `(ad-do-return [VALUE])'." ad-advised-functions))) (defmacro ad-do-advised-functions (varform &rest body) - "`ad-dolist'-style iterator that maps over `ad-advised-functions'. + "`dolist'-style iterator that maps over `ad-advised-functions'. \(ad-do-advised-functions (VAR [RESULT-FORM]) BODY-FORM...) On each iteration VAR will be bound to the name of an advised function \(a symbol)." - `(ad-dolist (,(car varform) + (declare (indent 1)) + `(cl-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)) + (setq ,(car varform) (intern (car ,(car varform)))) + ,@body)) (defun ad-get-advice-info (function) (get function 'ad-advice-info)) @@ -2021,7 +1862,7 @@ On each iteration VAR will be bound to the name of an advised function `(put ,function 'ad-advice-info ,advice-info)) (defmacro ad-copy-advice-info (function) - `(ad-copy-tree (get ,function 'ad-advice-info))) + `(copy-tree (get ,function 'ad-advice-info))) (defmacro ad-is-advised (function) "Return non-nil if FUNCTION has any advice info associated with it. @@ -2095,8 +1936,8 @@ either t or nil, and DEFINITION should be a list of the form (defun ad-has-enabled-advice (function class) "True if at least one of FUNCTION's advices in CLASS is enabled." - (ad-dolist (advice (ad-get-advice-info-field function class)) - (if (ad-advice-enabled advice) (ad-do-return t)))) + (cl-dolist (advice (ad-get-advice-info-field function class)) + (if (ad-advice-enabled advice) (cl-return t)))) (defun ad-has-redefining-advice (function) "True if FUNCTION's advice info defines at least 1 redefining advice. @@ -2109,14 +1950,14 @@ Redefining advices affect the construction of an advised definition." (defun ad-has-any-advice (function) "True if the advice info of FUNCTION defines at least one advice." (and (ad-is-advised function) - (ad-dolist (class ad-advice-classes nil) + (cl-dolist (class ad-advice-classes nil) (if (ad-get-advice-info-field function class) - (ad-do-return t))))) + (cl-return t))))) (defun ad-get-enabled-advices (function class) "Return the list of enabled advices of FUNCTION in CLASS." (let (enabled-advices) - (ad-dolist (advice (ad-get-advice-info-field function class)) + (dolist (advice (ad-get-advice-info-field function class)) (if (ad-advice-enabled advice) (push advice enabled-advices))) (reverse enabled-advices))) @@ -2200,20 +2041,31 @@ Redefining advices affect the construction of an advised definition." ;; @@ Interactive input functions: ;; =============================== +(declare-function 'function-called-at-point "help") + (defun ad-read-advised-function (&optional prompt predicate default) "Read 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)." +be returned on empty input (defaults to the first advised function or +function at point 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 + ;; Prefer func name at point, if it's in ad-advised-functions etc. + (let ((function (progn + (require 'help) + (function-called-at-point)))) + (and function + (assoc (symbol-name function) ad-advised-functions) + (or (null predicate) + (funcall predicate function)) + function)) (ad-do-advised-functions (function) (if (or (null predicate) (funcall predicate function)) - (ad-do-return function))) + (cl-return function))) (error "ad-read-advised-function: %s" "There are no qualifying advised functions"))) (let* ((ad-pReDiCaTe predicate) @@ -2226,7 +2078,7 @@ which PREDICATE returns non-nil)." (lambda (function) ;; Oops, no closures - the joys of dynamic scoping: ;; `predicate' clashed with the `predicate' argument - ;; of Lemacs' `completing-read'..... + ;; of `completing-read'..... (funcall ad-pReDiCaTe (intern (car function)))))) t))) (if (equal function "") @@ -2246,9 +2098,9 @@ be returned on empty input (defaults to the first non-empty advice class of FUNCTION)." (setq default (or default - (ad-dolist (class ad-advice-classes) + (cl-dolist (class ad-advice-classes) (if (ad-get-advice-info-field function class) - (ad-do-return class))) + (cl-return class))) (error "ad-read-advice-class: `%s' has no advices" function))) (let ((class (completing-read (format "%s (default %s): " (or prompt "Class") default) @@ -2317,18 +2169,18 @@ NAME can be a symbol or a regular expression matching part of an advice name. If CLASS is `any' all valid advice classes will be checked." (if (ad-is-advised function) (let (found-advice) - (ad-dolist (advice-class ad-advice-classes) + (cl-dolist (advice-class ad-advice-classes) (if (or (eq class 'any) (eq advice-class class)) (setq found-advice - (ad-dolist (advice (ad-get-advice-info-field + (cl-dolist (advice (ad-get-advice-info-field function advice-class)) (if (or (and (stringp name) (string-match name (symbol-name (ad-advice-name advice)))) (eq name (ad-advice-name advice))) - (ad-do-return advice))))) - (if found-advice (ad-do-return found-advice)))))) + (cl-return advice))))) + (if found-advice (cl-return found-advice)))))) (defun ad-enable-advice-internal (function class name flag) "Set enable FLAG of FUNCTION's advices in CLASS matching NAME. @@ -2339,10 +2191,10 @@ considered. The number of changed advices will be returned (or nil if FUNCTION was not advised)." (if (ad-is-advised function) (let ((matched-advices 0)) - (ad-dolist (advice-class ad-advice-classes) + (dolist (advice-class ad-advice-classes) (if (or (eq class 'any) (eq advice-class class)) - (ad-dolist (advice (ad-get-advice-info-field - function advice-class)) + (dolist (advice (ad-get-advice-info-field + function advice-class)) (cond ((or (and (stringp name) (string-match name (symbol-name (ad-advice-name advice)))) @@ -2503,12 +2355,6 @@ See Info node `(elisp)Computed Advice' for detailed documentation." ;;"non-nil if DEFINITION is a piece of advice." `(eq (car-safe ,definition) 'advice)) -;; Emacs/Lemacs cross-compatibility -;; (compiled-function-p is an obsolete function in Emacs): -(if (and (not (fboundp 'byte-code-function-p)) - (fboundp 'compiled-function-p)) - (ad-safe-fset 'byte-code-function-p 'compiled-function-p)) - (defmacro ad-compiled-p (definition) "Return non-nil if DEFINITION is a compiled byte-code object." `(or (byte-code-function-p ,definition) @@ -2535,59 +2381,12 @@ See Info node `(elisp)Computed Advice' for detailed documentation." "Return the argument list of DEFINITION. If DEFINITION could be from a subr then its NAME should be supplied to make subr arglist lookup more efficient." - (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 (match-string 1 name))))))) - -;; 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)'." - (if (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. - (let ((doc (or (ad-real-documentation subr-name t) ""))) - (if (not (string-match "\n\n\\((.+)\\)\\'" doc)) - ;; Signalling an error leads to bugs during bootstrapping because - ;; the DOC file is not yet built (which is an error, BTW). - ;; (error "The usage info is missing from the subr %s" subr-name) - '(&rest ad-subr-args) - (ad-define-subr-args - subr-name - (cdr (car (read-from-string - (downcase (match-string 1 doc)))))) - (ad-get-subr-args subr-name))))) + (require 'help-fns) + (help-function-arglist + (if (or (ad-macro-p definition) (ad-advice-p definition)) + (cdr definition) + definition) + 'preserve-names)) (defun ad-docstring (definition) "Return the unexpanded docstring of DEFINITION." @@ -2635,24 +2434,23 @@ definition (see the code for `documentation')." (defun ad-definition-type (definition) "Return 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))))) + (cond + ((ad-macro-p definition) 'macro) + ((ad-subr-p definition) + (if (ad-special-form-p definition) + 'special-form + 'subr)) + ((or (ad-lambda-p definition) + (ad-compiled-p definition)) + 'function) + ((ad-advice-p definition) 'advice))) (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)))) + (not (autoloadp (symbol-function function))))) ;; The following two are necessary for the sake of packages such as ;; ange-ftp which redefine functions via fcell indirection: @@ -2696,41 +2494,6 @@ For that it has to be fbound with a non-autoload definition." (byte-compile symbol) (fset function (symbol-function symbol)))))) - -;; @@ 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: ;; ============================= @@ -3007,11 +2770,9 @@ in any of these classes." (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage))) (if origdoc (setq paragraphs (list origdoc))) (unless (eq style 'plain) - (push (propertize (concat "This " origtype " is advised.") - 'face 'font-lock-warning-face) - paragraphs)) - (ad-dolist (class ad-advice-classes) - (ad-dolist (advice (ad-get-enabled-advices function class)) + (push (concat "This " origtype " is advised.") paragraphs)) + (dolist (class ad-advice-classes) + (dolist (advice (ad-get-enabled-advices function class)) (setq advice-docstring (ad-make-single-advice-docstring advice class style)) (if advice-docstring @@ -3033,24 +2794,24 @@ in any of these classes." (defun ad-advised-arglist (function) "Find first defined arglist in FUNCTION's redefining advices." - (ad-dolist (advice (append (ad-get-enabled-advices function 'before) + (cl-dolist (advice (append (ad-get-enabled-advices function 'before) (ad-get-enabled-advices function 'around) (ad-get-enabled-advices function 'after))) (let ((arglist (ad-arglist (ad-advice-definition advice)))) (if arglist ;; We found the first one, use it: - (ad-do-return arglist))))) + (cl-return arglist))))) (defun ad-advised-interactive-form (function) "Find first interactive form in FUNCTION's redefining advices." - (ad-dolist (advice (append (ad-get-enabled-advices function 'before) + (cl-dolist (advice (append (ad-get-enabled-advices function 'before) (ad-get-enabled-advices function 'around) (ad-get-enabled-advices function 'after))) (let ((interactive-form (ad-interactive-form (ad-advice-definition advice)))) (if interactive-form ;; We found the first one, use it: - (ad-do-return interactive-form))))) + (cl-return interactive-form))))) ;; @@@ Putting it all together: ;; ============================ @@ -3137,49 +2898,51 @@ definition, INTERACTIVE if non-nil is the interactive form to be used, ORIG is a form that calls the body of the original unadvised function, and BEFORES, AROUNDS and AFTERS are the lists of advices with which ORIG should be modified. The assembled function will be returned." - - (let (before-forms around-form around-form-protected after-forms definition) - (ad-dolist (advice befores) - (cond ((and (ad-advice-protected advice) - before-forms) - (setq before-forms - `((unwind-protect - ,(ad-prognify before-forms) - ,@(ad-body-forms - (ad-advice-definition advice)))))) - (t (setq before-forms - (append before-forms - (ad-body-forms (ad-advice-definition advice))))))) - - (setq around-form `(setq ad-return-value ,orig)) - (ad-dolist (advice (reverse arounds)) - ;; If any of the around advices is protected then we - ;; protect the complete around advice onion: - (if (ad-advice-protected advice) - (setq around-form-protected t)) - (setq around-form - (ad-substitute-tree - (function (lambda (form) (eq form 'ad-do-it))) - (function (lambda (form) around-form)) - (ad-prognify (ad-body-forms (ad-advice-definition advice)))))) + ;; The ad-do-it call should always have the right number of arguments, + ;; but the compiler might signal a bogus warning because it checks the call + ;; against the advertised calling convention. + (let ((around-form `(setq ad-return-value (with-no-warnings ,orig))) + before-forms around-form-protected after-forms definition) + (dolist (advice befores) + (cond ((and (ad-advice-protected advice) + before-forms) + (setq before-forms + `((unwind-protect + ,(macroexp-progn before-forms) + ,@(ad-body-forms + (ad-advice-definition advice)))))) + (t (setq before-forms + (append before-forms + (ad-body-forms (ad-advice-definition advice))))))) + + (dolist (advice (reverse arounds)) + ;; If any of the around advices is protected then we + ;; protect the complete around advice onion: + (if (ad-advice-protected advice) + (setq around-form-protected t)) + (setq around-form + (ad-substitute-tree + (function (lambda (form) (eq form 'ad-do-it))) + (function (lambda (form) around-form)) + (macroexp-progn (ad-body-forms (ad-advice-definition advice)))))) (setq after-forms (if (and around-form-protected before-forms) `((unwind-protect - ,(ad-prognify before-forms) + ,(macroexp-progn before-forms) ,around-form)) (append before-forms (list around-form)))) - (ad-dolist (advice afters) - (cond ((and (ad-advice-protected advice) - after-forms) - (setq after-forms - `((unwind-protect - ,(ad-prognify after-forms) - ,@(ad-body-forms - (ad-advice-definition advice)))))) - (t (setq after-forms - (append after-forms - (ad-body-forms (ad-advice-definition advice))))))) + (dolist (advice afters) + (cond ((and (ad-advice-protected advice) + after-forms) + (setq after-forms + `((unwind-protect + ,(macroexp-progn after-forms) + ,@(ad-body-forms + (ad-advice-definition advice)))))) + (t (setq after-forms + (append after-forms + (ad-body-forms (ad-advice-definition advice))))))) (setq definition `(,@(if (memq type '(macro special-form)) '(macro)) @@ -3203,7 +2966,7 @@ should be modified. The assembled function will be returned." (ad-body-forms (ad-advice-definition advice)))) (ad-get-enabled-advices function hook-name)))) (if hook-forms - (ad-prognify (apply 'append hook-forms))))) + (macroexp-progn (apply 'append hook-forms))))) ;; @@ Caching: @@ -3313,11 +3076,11 @@ advised definition from scratch." (nth 2 cache-id))))) (defun ad-verify-cache-class-id (cache-class-id advices) - (ad-dolist (advice advices (null cache-class-id)) + (cl-dolist (advice advices (null cache-class-id)) (if (ad-advice-enabled advice) (if (eq (car cache-class-id) (ad-advice-name advice)) (setq cache-class-id (cdr cache-class-id)) - (ad-do-return nil))))) + (cl-return nil))))) ;; There should be a way to monitor if and why a cache verification failed ;; in order to determine whether a certain preactivation could be used or @@ -3812,7 +3575,16 @@ See Info node `(elisp)Advising Functions' for comprehensive documentation. usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) [DOCSTRING] [INTERACTIVE-FORM] BODY...)" - (declare (doc-string 3)) + (declare (doc-string 3) + (debug (&define name ;; thing being advised. + (name ;; class is [&or "before" "around" "after" + ;; "activation" "deactivation"] + name ;; name of advice + &rest sexp ;; optional position and flags + ) + [&optional stringp] + [&optional ("interactive" interactive)] + def-body))) (if (not (ad-name-p function)) (error "defadvice: Invalid function name: %s" function)) (let* ((class (car args)) @@ -3881,6 +3653,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) For any members of FUNCTIONS that are not currently advised the rebinding will be a noop. Any modifications done to the definitions of FUNCTIONS will be undone on exit of this macro." + (declare (indent 1)) (let* ((index -1) ;; Make let-variables to store current definitions: (current-bindings @@ -3920,18 +3693,6 @@ undone on exit of this macro." ,(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: - -;; This makes sure we get the right arglist for `documentation' -;; during bootstrapping. -(ad-define-subr-args 'documentation '(function &optional raw)) ;; @@ Starting, stopping and recovering from the advice package magic: ;; =================================================================== @@ -3965,5 +3726,4 @@ Use only in REAL emergencies." (provide 'advice) -;; arch-tag: 29f8c9a1-8c88-471f-95d7-e28541c6b7c0 ;;; advice.el ends here diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el deleted file mode 100644 index c125276b218..00000000000 --- a/lisp/emacs-lisp/assoc.el +++ /dev/null @@ -1,142 +0,0 @@ -;;; assoc.el --- insert/delete/sort functions on association lists - -;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011, 2012 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 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Association list utilities providing insertion, deletion, sorting -;; fetching off key-value pairs in association lists. - -;;; Code: -(eval-when-compile (require 'cl)) - -(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) - "Make a list of a cons cell containing car of KEY and cdr of VALUE. -The returned list is suitable for concatenating with an existing -alist, via `nconc'." - (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)." - (lexical-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) - (lexical-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) - "Return 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." - (lexical-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) - -;; arch-tag: 3e58bd89-d912-4b74-a0dc-6ed9735922bc -;;; assoc.el ends here diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index f1189fbea8f..270badd53cb 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -1,11 +1,11 @@ -;;; authors.el --- utility for maintaining Emacs' AUTHORS file -*-coding: utf-8;-*- +;;; authors.el --- utility for maintaining Emacs's AUTHORS file -*-coding: utf-8 -*- -;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2000-2013 Free Software Foundation, Inc. ;; Author: Gerd Moellmann <gerd@gnu.org> ;; Maintainer: Kim F. Storm <storm@cua.dk> ;; Keywords: maint +;; Package: emacs ;; This file is part of GNU Emacs. @@ -25,7 +25,7 @@ ;;; Commentary: ;; Use M-x authors RET to create an *Authors* buffer that can used as -;; or merged with Emacs' AUTHORS file. +;; or merged with Emacs's AUTHORS file. ;;; Code: @@ -41,23 +41,28 @@ files.") (defconst authors-aliases '( ("Aaron S. Hawley" "Aaron Hawley") + ("Alexandru Harsanyi" "Alex Harsanyi") ("Andrew Csillag" "Drew Csillag") ("Anna M. Bigatti" "Anna Bigatti") ("Barry A. Warsaw" "Barry A. Warsaw, Century Computing, Inc." "Barry A. Warsaw, ITB" "Barry Warsaw") + ("Bill Carpenter" "WJ Carpenter") ("Bill Mann" "William F. Mann") ("Bill Rozas" "Guillermo J. Rozas") ("Björn Torkelsson" "Bjorn Torkelsson") ("Brian Fox" "Brian J. Fox") + ("Brian Sniffen" "Brian T. Sniffen") ("Christoph Wedler" "Christoph.Wedler@sap.com") ("Daniel Pfeiffer" "<Daniel.Pfeiffer@Informatik.START.db.de>" "<Daniel.Pfeiffer@Informatik.START.dbp.de>") + ("David Abrahams" "Dave Abrahams") ("David De La Harpe Golden" "David Golden") ("David Gillespie" "Dave Gillespie") ("David KÃ¥gedal" "David K..edal") ("David M. Koppelman" "David M. Koppelman, Koppel@Ec?e.Lsu.Edu" "David Koppelman") ("David M. Smith" "David Smith" "David M Smith") + ("David O'Toole" "David T. O'Toole") ("Deepak Goel" "D. Goel") ("Ed L. Cashin" "Ed L Cashin") ("Edward M. Reingold" "Ed Reingold" "Edward M Reingold" @@ -76,6 +81,8 @@ files.") ("Gerd Möllmann" "Gerd Moellmann") ("Hallvard B. Furuseth" "Hallvard B Furuseth" "Hallvard Furuseth") ("Hrvoje NikÅ¡ić" "Hrvoje Niksic") + ;; lisp/org/ChangeLog 2010-11-11. + (nil "aaa bbb") ;; src/ChangeLog.4, 1994-01-11, since fixed. ;;; (nil "(afs@hplb.hpl.hp.com)") ;; lisp/gnus/ChangeLog.1, 1998-01-15. @@ -92,6 +99,7 @@ files.") ("Jens-Ulrik Holger Petersen" "Jens-Ulrik Petersen") ("Jeremy Bertram Maitin-Shepard" "Jeremy Maitin-Shepard") ("Johan BockgÃ¥rd" "Johan Bockgard") + ("John J Foerch" "John Foerch") ("John W. Eaton" "John Eaton") ("Jonathan I. Kamens" "Jonathan Kamens") ("Joseph Arceneaux" "Joe Arceneaux") @@ -109,10 +117,11 @@ files.") ("Kevin Greiner" "Kevin J. Greiner") ("Kim F. Storm" "Kim Storm") ("Kyle Jones" "Kyle E. Jones") + ("Lars Magne Ingebrigtsen" "Lars Ingebrigtsen") ("Marcus G. Daniels" "Marcus Daniels") ("Mark D. Baushke" "Mark D Baushke") ("Marko Kohtala" "Kohtala Marko") - ("AgustÃn MartÃn" "Agustin Martin") + ("AgustÃn MartÃn" "Agustin Martin" "AgustÃn MartÃn Domingo") ("Martin Lorentzon" "Martin Lorentzson") ("Matt Swift" "Matthew Swift") ("Maxime Edouard Robert Froumentin" "Max Froumentin") @@ -124,12 +133,14 @@ files.") ("Michael Sperber" "Michael Sperber \\[Mr. Preprocessor\\]") ("Mikio Nakajima" "Nakajima Mikio") ("Nelson Jose dos Santos Ferreira" "Nelson Ferreira") + ("Noorul Islam" "Noorul Islam K M") ("Paul Eggert" "eggert") ("Paul Reilly" "(pmr@legacy.pajato.com)") ("Pavel JanÃk" "Pavel JanÃk Ml." "Pavel Janik Ml." "Pavel Janik" "Pavel JanÃk" "Pavel@Janik.Cz") ("Pavel Kobiakov" "Pavel Kobyakov") ("Per Abrahamsen" "Per Abhiddenware") ("Per Starbäck" "Per Starback") + ("Peter J. Weisberg" "PJ Weisberg") ("Peter S. Galbraith" "Peter Galbraith") ("Peter Runestig" "Peter 'luna' Runestig") ("Peter S. Galbraith" "Peter S Galbraith") @@ -144,23 +155,28 @@ files.") ("Sacha Chua" "Sandra Jean Chua") ("Sam Steingold" "Sam Shteingold") ("Satyaki Das" "Indexed search by Satyaki Das") + ("Sébastien Vauban" "Sebastien Vauban") ;; There are other Stefans. ;;; ("Stefan Monnier" "Stefan") ("Stephen A. Wood" "(saw@cebaf.gov)") ("Steven L. Baur" "SL Baur" "Steven L Baur") ("Stewart M. Clamen" "Stewart Clamen") ("Stuart D. Herring" "Stuart Herring" "Davis Herring") + ("T.V. Raman" "T\\. V\\. Raman") ("Taichi Kawabata" "KAWABATA,? Taichi") ("Takaaki Ota" "Tak Ota") ("Takahashi Naoto" "Naoto Takahashi") ("Teodor Zlatanov" "Ted Zlatanov") + ("Thomas Dye" "Tom Dye") ("Thomas Horsley" "Tom Horsley") ; FIXME ? ("Thomas Wurgler" "Tom Wurgler") + ("Toby Cubitt" "Toby S\\. Cubitt") ("Tomohiko Morioka" "MORIOKA Tomohiko") ("Torbjörn Axelsson" "Torbjvrn Axelsson") ("Torbjörn Einarsson" "Torbj.*rn Einarsson") ("Toru Tomabechi" "Toru Tomabechi,") ("Tsugutomo Enami" "enami tsugutomo") + ("Ulrich Müller" "Ulrich Mueller") ("Vincent Del Vecchio" "Vince Del Vecchio") ("William M. Perry" "Bill Perry") ("Wlodzimierz Bzyl" "W.*dek Bzyl") @@ -174,6 +190,7 @@ Each entry is of the form (REALNAME REGEXP...). If an author's name matches one of the REGEXPs, use REALNAME instead. If REALNAME is nil, ignore that author.") +;; FIXME seems it would be less fragile to check for O', Mc, etc. (defconst authors-fixed-case '("Bryan O'Sullivan" "Christian von Roques" @@ -182,6 +199,7 @@ If REALNAME is nil, ignore that author.") "David J. MacKenzie" "David McCabe" "David O'Toole" + "Devon Sean McCullough" "Dominique de Waleffe" "Edward O'Connor" "Exal de Jesus Garcia Carrillo" @@ -194,8 +212,11 @@ If REALNAME is nil, ignore that author.") "Nelson Jose dos Santos Ferreira" "Peter von der Ahe" "Peter O'Gorman" + "Piet van Oostrum" "Roland McGrath" - "Sean O'Rourke") + "Sean O'Halpin" + "Sean O'Rourke" + "Tijs van Bakel") "List of authors whose names cannot be simply capitalized.") (defvar authors-public-domain-files @@ -220,10 +241,14 @@ If REALNAME is nil, ignore that author.") '("vc-\\*\\.el$" "spec.txt$" ".*loaddefs.el$" ; not obsolete, but auto-generated + "\\.\\(cvs\\|git\\)ignore$" ; obsolete or uninteresting + "\\.arch-inventory$" + ;; TODO lib/? Matches other things? + "build-aux/" "m4/" "Emacs.xcodeproj" "charsets" "mapfiles" + "preferences\\.\\(nib\\|gorm\\)" "vc-\\(rcs\\|cvs\\|sccs\\)-hooks\\.el$") "List of regexps matching obsolete files. -Changes to files matching one of the regexps in this list are not -listed.") +Changes to files matching one of the regexps in this list are not listed.") (defconst authors-ignored-files '("external-lisp" @@ -244,9 +269,22 @@ listed.") "Imakefile" "icons/sink.ico" "aixcc.lex" "nxml/char-name/unicode" "js2-mode.el" ; only installed very briefly, replaced by js.el + "cedet/tests/testtemplates.cpp" + "cedet/tests/testusing.cpp" + "cedet/tests/scopetest.cpp" + "cedet/tests/scopetest.java" + "cedet/tests/test.cpp" + "cedet/tests/test.py" + "cedet/tests/teststruct.cpp" + "*.el" ;; Autogen: "cus-load.el" "finder-inf.el" "ldefs-boot.el" + "compile" "config.guess" "config.sub" "depcomp" + ;; Only existed briefly, then renamed: + "images/icons/allout-widgets-dark-bg" + "images/icons/allout-widgets-light-bg" ;; Never had any meaningful changes logged, now deleted: + "unidata/bidimirror.awk" "unidata/biditype.awk" "split-man" "Xkeymap.txt" "ms-7bkermit" "ulimit.hack" "gnu-hp300" "refcard.bit" "ledit.l" "forms.README" "forms-d2.dat" "CXTERM-DIC/PY.tit" "CXTERM-DIC/ZIRANMA.tit" @@ -255,7 +293,16 @@ listed.") "3B-MAXMEM" "AIX.DUMP" "SUN-SUPPORT" "XENIX" "CODINGS" "CHARSETS" "calc/INSTALL" "calc/Makefile" - "vms-pp.trans" "_emacs" "batcomp.com" + "vms-pp.trans" "_emacs" "batcomp.com" "notes/cpp" ; admin/ + "emacsver.texi.in" + "vpath.sed" + "Cocoa/Emacs.base/Contents/Info.plist" + "Cocoa/Emacs.base/Contents/Resources/English.lproj/InfoPlist.strings" + "GNUstep/Emacs.base/Resources/Info-gnustep.plist" + "GNUstep/Emacs.base/Resources/Emacs.desktop" + "Cocoa/Emacs.base/Contents/Resources/English.lproj" + ;; Only existed briefly, then deleted: + "coccinelle/overlay.cocci" "coccinelle/symbol.cocci" ;; MH-E stuff not in Emacs: "import-emacs" "release-utils" ;; Erc stuff not in Emacs: @@ -286,6 +333,60 @@ listed.") "List of files and directories to ignore. Changes to files in this list are not listed.") +;; List via: find . -name '*.el' | sed 's/.*\///g' | sort | uniq -d +;; FIXME It would be better to discover these dynamically. +;; Note that traditionally "Makefile.in" etc have not been in this list. +;; Ditto for "abbrev.texi" etc. +(defconst authors-ambiguous-files + '("chart.el" + "compile.el" + "complete.el" + "cpp.el" + "ctxt.el" + "custom.el" + "cyrillic.el" + "czech.el" + "debug.el" + "dired.el" + "el.el" + "eshell.el" + "ethiopic.el" + "f90.el" + "files.el" + "find.el" + "format.el" + "generic.el" + "georgian.el" + "greek.el" + "grep.el" + "hebrew.el" + "imenu.el" + "indian.el" + "japanese.el" + "java.el" + "lao.el" + "linux.el" + "locate.el" + "make.el" + "mode.el" + "python.el" + "rmailmm.el" + "semantic.el" + "shell.el" + "simple.el" + "slovak.el" + "sort.el" + "speedbar.el" + "srecode.el" + "table.el" + "texi.el" + "thai.el" + "tibetan.el" + "util.el" + "vc-bzr.el" + "wisent.el") + "List of basenames occurring more than once in the source.") + ;; FIXME :cowrote entries here can be overwritten by :wrote entries ;; derived from a file's Author: header (eg mh-e). This really means ;; the Author: header is erroneous. @@ -306,8 +407,8 @@ Changes to files in this list are not listed.") ("Lawrence R. Dodd" :cowrote "dired-x.el") ;; No longer distributed. ;;; ("Viktor Dukhovni" :wrote "unexsunos4.c") - ("Paul Eggert" :wrote "rcs2log" "vcdiff") - ("Fred Fish" :changed "unexec.c") + ("Paul Eggert" :wrote "rcs2log") ; "vcdiff" + ("Fred Fish" :changed "unexcoff.c") ;; No longer distributed. ;;; ("Tim Fleehart" :wrote "makefile.nt") ("Keith Gabryelski" :wrote "hexl.c") @@ -330,13 +431,13 @@ Changes to files in this list are not listed.") "indent.c" "search.c" "xdisp.c" "region-cache.c" "region-cache.h") ;; ibmrt.h, ibmrt-aix.h no longer distributed. ("International Business Machines" :changed "emacs.c" "fileio.c" - "process.c" "sysdep.c" "unexec.c") + "process.c" "sysdep.c" "unexcoff.c") ;; No longer distributed. ;;; ("Ishikawa Chiaki" :changed "aviion.h" "dgux.h") ;; ymakefile no longer distributed. - ("Michael K. Johnson" :changed "configure.in" "emacs.c" "intel386.h" + ("Michael K. Johnson" :changed "configure.ac" "emacs.c" "intel386.h" "mem-limits.h" "process.c" "template.h" "sysdep.c" "syssignal.h" - "systty.h" "unexec.c" "linux.h") + "systty.h" "unexcoff.c" "linux.h") ;; No longer distributed. ;;; ("Kyle Jones" :wrote "mldrag.el") ("Henry Kautz" :wrote "bib-mode.el") @@ -361,7 +462,7 @@ Changes to files in this list are not listed.") "rmail.el" "rmailedit.el" "rmailkwd.el" "rmailmsc.el" "rmailout.el" "rmailsum.el" "scribe.el" ;; It was :wrote for xmenu.c, but it has been rewritten since. - "server.el" "lisp.h" "sysdep.c" "unexec.c" "xmenu.c") + "server.el" "lisp.h" "sysdep.c" "unexcoff.c" "xmenu.c") ("Niall Mansfield" :changed "etags.c") ("Brian Marick" :cowrote "hideif.el") ("Marko Kohtala" :changed "info.el") @@ -373,7 +474,8 @@ Changes to files in this list are not listed.") "vt220.el" "vt240.el") ("Motorola" :changed "buff-menu.el") ("Hiroshi Nakano" :changed "ralloc.c") - ("Sundar Narasimhan" :changed "rnewspost.el") + ;; File removed in Emacs 24.1. +;;; ("Sundar Narasimhan" :changed "rnewspost.el") ;; No longer distributed. ;;; ("NeXT, Inc." :wrote "unexnext.c") ("Mark Neale" :changed "fortran.el") @@ -389,7 +491,7 @@ Changes to files in this list are not listed.") ;; No longer distributed. ;;; "vmspaths.h" "build.com" "compile.com" "kepteditor.com" "precomp.com" ;;; "vmsproc.el" :wrote "logout.com" "mailemacs.com") - ("Guillermo J. Rozas" :wrote "fakemail.c") +;;; ("Guillermo J. Rozas" :wrote "fakemail.c") ("Wolfgang Rupprecht" :changed "lisp-mode.el" "loadup.el" "sort.el" "alloc.c" "callint.c" ;; config.in renamed from config.h.in; ecrt0.c from crt0.c. @@ -404,7 +506,7 @@ Changes to files in this list are not listed.") ("William Sommerfeld" :wrote "emacsclient.c" "scribe.el") ;; No longer distributed: emacsserver.c. ("Leigh Stoller" :changed "emacsclient.c" "server.el") - ("Steve Strassman" :wrote "spook.el") + ("Steve Strassmann" :wrote "spook.el") ("Shinichirou Sugou" :changed "etags.c") ;; No longer distributed: emacsserver.c. ("Sun Microsystems, Inc" :changed "emacsclient.c" "server.el" @@ -416,9 +518,9 @@ Changes to files in this list are not listed.") ("Kayvan Sylvan" :changed "supercite.el") ;; No longer distributed: emacsserver.c, tcp.c. ("Spencer Thomas" :changed "emacsclient.c" "server.el" - "dabbrev.el" "unexec.c" "gnus.texi") + "dabbrev.el" "unexcoff.c" "gnus.texi") ("Jonathan Vail" :changed "vc.el") - ("James Van Artsdalen" :changed "usg5-4.h" "unexec.c") + ("James Van Artsdalen" :changed "usg5-4.h" "unexcoff.c") ;; No longer distributed: src/makefile.nt, lisp/makefile.nt ;; winnt.el renamed to w32-fns.el; nt.[ch] to w32.[ch]; ;; ntheap.[ch] to w32heap.[ch]; ntinevt.c to w32inevt.c; @@ -427,6 +529,7 @@ Changes to files in this list are not listed.") ("Geoff Voelker" :wrote "w32-fns.el" "w32.c" "w32.h" "w32heap.c" "w32heap.h" "w32inevt.c" "w32proc.c" "w32term.c" "ms-w32.h") ("Morten Welinder" :wrote "dosfns.c" "[many MS-DOS files]" "msdos.h") + ("Eli Zaretskii" :wrote "bidi.c" "[bidirectional display in xdisp.c]") ;; Not using this version any more. ;;; ("Pace Willisson" :wrote "ispell.el") ;; FIXME overwritten by Author:. @@ -445,6 +548,7 @@ Changes to files in this list are not listed.") "makedist.bat" "makefile.def" "makefile.nt" + "ns.mk" "debug.bat.in" "emacs.bat.in" ".gdbinit-union" "alloca.s" @@ -457,17 +561,25 @@ Changes to files in this list are not listed.") "getdate.y" "ymakefile" "permute-index" "index.perm" + "ibmrs6000.inp" + "b2m.c" "b2m.1" "b2m.pl" "rcs-checkin.1" + "emacs.bash" "emacs.csh" "ms-kermit" "emacs.ico" "emacs21.ico" - "LPF" "LEDIT" "OTHER.EMACSES" + "emacs.py" "emacs2.py" "emacs3.py" + "BABYL" "LPF" "LEDIT" "OTHER.EMACSES" "emacs16_mac.png" "emacs24_mac.png" "emacs256_mac.png" "emacs32_mac.png" "emacs48_mac.png" "emacs512_mac.png" + "revdiff" ; admin/ + "vcdiff" "rcs-checkin" "tindex.pl" + "mainmake" "sed1.inp" "sed2.inp" "sed3.inp" ; msdos/ + "mac-fix-env.m" ;; Deleted vms stuff: "temacs.opt" "descrip.mms" "compile.com" "link.com" ) - "File names which are valid, but no longer exist (or cannot be -found) in the repository.") + "File names which are valid, but no longer exist (or cannot be found) +in the repository.") (defconst authors-renamed-files-alist '(("nt.c" . "w32.c") ("nt.h" . "w32.h") @@ -477,8 +589,11 @@ found) in the repository.") ("w32console.c" . "w32term.c") ("unexnt.c" . "unexw32.c") ("s/windowsnt.h" . "s/ms-w32.h") + ("s/ms-w32.h" . "inc/ms-w32.h") ("winnt.el" . "w32-fns.el") + ("emacs.manifest" . "emacs-x86.manifest") ("config.emacs" . "configure") + ("configure.in" . "configure.ac") ("config.h.dist" . "config.in") ("config.h-dist" . "config.in") ("config.h.in" . "config.in") @@ -504,6 +619,7 @@ found) in the repository.") ;; index and pick merged into search. ("mh-index.el" . "mh-search.el") ("mh-pick.el" . "mh-search.el") + ("font-setting.el" . "dynamic-setting.el") ;; INSTALL-CVS -> .CVS -> .BZR ("INSTALL-CVS" . "INSTALL.BZR") ("INSTALL.CVS" . "INSTALL.BZR") @@ -512,6 +628,8 @@ found) in the repository.") ("build-install" . "build-ins.in") ("build-install.in" . "build-ins.in") ("unidata/Makefile" . "unidata/Makefile.in") + ("move-if-change" . "build-aux/move-if-change") + ("update-subdirs" . "build-aux/update-subdirs") ;; Not renamed, but we only have the latter in the Emacs repo. ("trampver.texi.in" . "trampver.texi") ("e/eterm" . "e/eterm-color") @@ -529,12 +647,17 @@ found) in the repository.") ("schema/docbook-dyntbl.rnc" . "schema/docbk-dyntbl.rnc") ("schema/docbook-soextbl.rnc" . "schema/docbk-soextbl.rn" ) ("texi/url.txi" . "url.texi") + ("edt-user.doc" . "edt.texi") + ("DEV-NOTES" . "nextstep") + ("org/COPYRIGHT-AND-LICENSE" . "org/README") ;; Moved to different directories. ("ctags.1" . "ctags.1") ("etags.1" . "etags.1") ("emacs.1" . "emacs.1") ("emacsclient.1" . "emacsclient.1") ("icons/emacs21.ico" . "emacs21.ico") + ;; Moved from admin/nt/ to nt/. + ("nt/README.W32" . "README.W32") ) "Alist of files which have been renamed during their lifetime. Elements are (OLDNAME . NEWNAME).") @@ -573,14 +696,29 @@ Otherwise, the file name is accepted as is.") (defvar authors-checked-files-alist) (defvar authors-invalid-file-names) +(defun authors-disambiguate-file-name (fullname) + "Convert FULLNAME to an unambiguous relative-name." + (let ((relname (file-name-nondirectory fullname)) + parent) + (if (member relname authors-ambiguous-files) + ;; In case of ambiguity, just prepend the parent directory. + ;; FIXME obviously this is not a perfect solution. + (if (string-equal "lisp" + (setq parent (file-name-nondirectory + (directory-file-name + (file-name-directory fullname))))) + relname + (format "%s/%s" parent relname)) + relname))) + (defun authors-canonical-file-name (file log-file pos author) "Return canonical file name for FILE found in LOG-FILE. Checks whether FILE is a valid (existing) file name, has been renamed, -or is on the list of removed files. Returns the non-diretory part of +or is on the list of removed files. Returns the non-directory part of the file name. Only uses the LOG-FILE position POS and associated AUTHOR to print a message if FILE is not found." ;; FILE should be re-checked in every different directory associated - ;; with a LOG-FILE. Eg configure.in from src/ChangeLog is not the + ;; with a LOG-FILE. Eg configure.ac from src/ChangeLog is not the ;; same as that from top-level/ChangeLog. (let* ((fullname (expand-file-name file (file-name-directory log-file))) (entry (assoc fullname authors-checked-files-alist)) @@ -593,7 +731,7 @@ to print a message if FILE is not found." (file-exists-p file) (file-exists-p relname) (file-exists-p (concat "etc/" relname))) - (setq valid relname) + (setq valid (authors-disambiguate-file-name fullname)) (setq valid (assoc file authors-renamed-files-alist)) (if valid (setq valid (cdr valid)) @@ -610,6 +748,7 @@ to print a message if FILE is not found." (cons (cons fullname valid) authors-checked-files-alist)) (unless (or valid (member file authors-ignored-files) + (authors-obsolete-file-p file) (string-match "[*]" file) (string-match "^[0-9.]+$" file)) (setq authors-invalid-file-names @@ -707,7 +846,7 @@ with the file and the number of each action: (enable-local-eval nil) (existing-buffer (get-file-buffer log-file)) (buffer (find-file-noselect log-file)) - authors file pos) + authors pos) (with-current-buffer buffer (save-restriction (widen) @@ -758,7 +897,7 @@ TABLE is a hash table to add author information to." (enable-local-variables :safe) ; for find-file, hence let* (enable-local-eval nil) (buffer (find-file-noselect file))) - (setq file (file-name-nondirectory file)) + (setq file (authors-disambiguate-file-name (expand-file-name file))) (with-current-buffer buffer (save-restriction (widen) @@ -821,8 +960,7 @@ and changed by AUTHOR." (file (car change)) (filestat (if (authors-public-domain-p file) (concat file " (public domain)") - file)) - slot) + file))) (cond ((assq :wrote actions) (setq wrote-list (cons filestat wrote-list))) ((assq :cowrote actions) @@ -956,5 +1094,4 @@ the Emacs source tree, from which to build the file." (provide 'authors) -;; arch-tag: 659d5900-5ff2-43b0-954c-a315cc1e4dc1 ;;; authors.el ends here diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index d558f1a3f29..edaecd7ff19 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1,11 +1,10 @@ -;; autoload.el --- maintain autoloads in loaddefs.el +;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*- -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2001, 2002, -;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 1991-1997, 2001-2013 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Keywords: maint +;; Package: emacs ;; This file is part of GNU Emacs. @@ -33,13 +32,21 @@ (require 'lisp-mode) ;for `doc-string-elt' properties. (require 'help-fns) ;for help-add-fundoc-usage. -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) -(defvar 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. The autoload file is assumed to contain a -trailer starting with a FormFeed character.") +(defvar generated-autoload-file nil + "File into which to write autoload definitions. +A Lisp file can set this in its local variables section to make +its autoloads go somewhere else. + +If this is a relative file name, the directory is determined as +follows: + - If a Lisp file defined `generated-autoload-file' as a + file-local variable, use its containing directory. + - Otherwise use the \"lisp\" subdirectory of `source-directory'. + +The autoload file is assumed to contain a trailer starting with a +FormFeed character.") ;;;###autoload (put 'generated-autoload-file 'safe-local-variable 'stringp) @@ -79,59 +86,100 @@ that text will be copied verbatim to `generated-autoload-file'.") (defvar autoload-modified-buffers) ;Dynamically scoped var. -(defun make-autoload (form file) +(defun make-autoload (form file &optional expansion) "Turn FORM into an autoload or defvar for source file FILE. Returns nil if FORM is not a special autoload form (i.e. a function definition -or macro definition or a defcustom)." +or macro definition or a defcustom). +If EXPANSION is non-nil, we're processing the macro expansion of an +expression, in which case we want to handle forms differently." (let ((car (car-safe form)) expand) (cond + ((and expansion (eq car 'defalias)) + (pcase-let* + ((`(,_ ,_ ,arg . ,rest) form) + ;; `type' is non-nil if it defines a macro. + ;; `fun' is the function part of `arg' (defaults to `arg'). + ((or (and (or `(cons 'macro ,fun) `'(macro . ,fun)) (let type t)) + (and (let fun arg) (let type nil))) + arg) + ;; `lam' is the lambda expression in `fun' (or nil if not + ;; recognized). + (lam (if (memq (car-safe fun) '(quote function)) (cadr fun))) + ;; `args' is the list of arguments (or t if not recognized). + ;; `body' is the body of `lam' (or t if not recognized). + ((or `(lambda ,args . ,body) + (and (let args t) (let body t))) + lam) + ;; Get the `doc' from `body' or `rest'. + (doc (cond ((stringp (car-safe body)) (car body)) + ((stringp (car-safe rest)) (car rest)))) + ;; Look for an interactive spec. + (interactive (pcase body + ((or `((interactive . ,_) . ,_) + `(,_ (interactive . ,_) . ,_)) t)))) + ;; Add the usage form at the end where describe-function-1 + ;; can recover it. + (when (listp args) (setq doc (help-add-fundoc-usage doc args))) + ;; (message "autoload of %S" (nth 1 form)) + `(autoload ,(nth 1 form) ,file ,doc ,interactive ,type))) + + ((and expansion (memq car '(progn prog1))) + (let ((end (memq :autoload-end form))) + (when end ;Cut-off anything after the :autoload-end marker. + (setq form (copy-sequence form)) + (setcdr (memq :autoload-end form) nil)) + (let ((exps (delq nil (mapcar (lambda (form) + (make-autoload form file expansion)) + (cdr form))))) + (when exps (cons 'progn exps))))) + ;; For complex cases, try again on the macro-expansion. ((and (memq car '(easy-mmode-define-global-mode define-global-minor-mode - define-globalized-minor-mode + define-globalized-minor-mode defun defmacro + ;; FIXME: we'd want `defmacro*' here as well, so as + ;; to handle its `declare', but when autoload is run + ;; CL is not loaded so macroexpand doesn't know how + ;; to expand it! easy-mmode-define-minor-mode define-minor-mode)) (setq expand (let ((load-file-name file)) (macroexpand form))) - (eq (car expand) 'progn) - (memq :autoload-end expand)) - (let ((end (memq :autoload-end expand))) - ;; Cut-off anything after the :autoload-end marker. - (setcdr end nil) - (cons 'progn - (mapcar (lambda (form) (make-autoload form file)) - (cdr expand))))) + (memq (car expand) '(progn prog1 defalias))) + (make-autoload expand file 'expansion)) ;Recurse on the expansion. ;; For special function-like operators, use the `autoload' function. - ((memq car '(defun define-skeleton defmacro define-derived-mode + ((memq car '(define-skeleton define-derived-mode define-compilation-mode define-generic-mode easy-mmode-define-global-mode define-global-minor-mode define-globalized-minor-mode easy-mmode-define-minor-mode define-minor-mode - defun* defmacro* define-overloadable-function)) - (let* ((macrop (memq car '(defmacro defmacro*))) + cl-defun defun* cl-defmacro defmacro* + define-overloadable-function)) + (let* ((macrop (memq car '(defmacro cl-defmacro defmacro*))) (name (nth 1 form)) - (args (case car - ((defun defmacro defun* defmacro* - define-overloadable-function) (nth 2 form)) - ((define-skeleton) '(&optional str arg)) - ((define-generic-mode define-derived-mode - define-compilation-mode) nil) - (t))) - (body (nthcdr (get car 'doc-string-elt) form)) + (args (pcase car + ((or `defun `defmacro + `defun* `defmacro* `cl-defun `cl-defmacro + `define-overloadable-function) (nth 2 form)) + (`define-skeleton '(&optional str arg)) + ((or `define-generic-mode `define-derived-mode + `define-compilation-mode) nil) + (_ t))) + (body (nthcdr (or (function-get car 'doc-string-elt) 3) form)) (doc (if (stringp (car body)) (pop body)))) - (when (listp args) - ;; Add the usage form at the end where describe-function-1 - ;; can recover it. - (setq doc (help-add-fundoc-usage doc args))) - ;; `define-generic-mode' quotes the name, so take care of that - (list 'autoload (if (listp name) name (list 'quote name)) file doc - (or (and (memq car '(define-skeleton define-derived-mode - define-generic-mode - easy-mmode-define-global-mode - define-global-minor-mode - define-globalized-minor-mode - easy-mmode-define-minor-mode - define-minor-mode)) t) - (eq (car-safe (car body)) 'interactive)) - (if macrop (list 'quote 'macro) nil)))) + ;; Add the usage form at the end where describe-function-1 + ;; can recover it. + (when (listp args) (setq doc (help-add-fundoc-usage doc args))) + ;; `define-generic-mode' quotes the name, so take care of that + `(autoload ,(if (listp name) name (list 'quote name)) + ,file ,doc + ,(or (and (memq car '(define-skeleton define-derived-mode + define-generic-mode + easy-mmode-define-global-mode + define-global-minor-mode + define-globalized-minor-mode + easy-mmode-define-minor-mode + define-minor-mode)) t) + (eq (car-safe (car body)) 'interactive)) + ,(if macrop ''macro nil)))) ;; For defclass forms, use `eieio-defclass-autoload'. ((eq car 'defclass) @@ -164,6 +212,11 @@ or macro definition or a defcustom)." (if (member ',file loads) nil (put ',groupname 'custom-loads (cons ',file loads)))))) + ;; When processing a macro expansion, any expression + ;; before a :autoload-end should be included. These are typically (put + ;; 'fun 'prop val) and things like that. + ((and expansion (consp form)) form) + ;; nil here indicates that this is not a special autoload form. (t nil)))) @@ -172,6 +225,16 @@ or macro definition or a defcustom)." ;; the doc-string in FORM. ;; Those properties are now set in lisp-mode.el. +(defun autoload-find-generated-file () + "Visit the autoload file for the current buffer, and return its buffer. +If a buffer is visiting the desired autoload file, return it." + (let ((enable-local-variables :safe) + (enable-local-eval nil)) + ;; We used to use `raw-text' to read this file, but this causes + ;; problems when the file contains non-ASCII characters. + (find-file-noselect + (autoload-ensure-default-file (autoload-generated-file))))) + (defun autoload-generated-file () (expand-file-name generated-autoload-file ;; File-local settings of generated-autoload-file should @@ -215,7 +278,7 @@ put the output in." ;; Symbols at the toplevel are meaningless. ((symbolp form) nil) (t - (let ((doc-string-elt (get (car-safe form) 'doc-string-elt)) + (let ((doc-string-elt (function-get (car-safe form) 'doc-string-elt)) (outbuf autoload-print-form-outbuf)) (if (and doc-string-elt (stringp (nth doc-string-elt form))) ;; We need to hack the printing because the @@ -259,14 +322,17 @@ put the output in." TYPE (default \"autoloads\") is a string stating the type of information contained in FILE. If FEATURE is non-nil, FILE will provide a feature. FEATURE may be a string naming the -feature, otherwise it will be based on FILE's name." +feature, otherwise it will be based on FILE's name. + +At present, a feature is in fact always provided, but this should +not be relied upon." (let ((basename (file-name-nondirectory file))) (concat ";;; " basename " --- automatically extracted " (or type "autoloads") "\n" ";;\n" ";;; Code:\n\n" " \n" - ;; This is used outside of autoload.el. + ;; This is used outside of autoload.el, eg cus-dep, finder. "(provide '" (if (stringp feature) feature @@ -291,7 +357,7 @@ feature, otherwise it will be based on FILE's name." "Insert the section-header line, which lists the file name and which functions are in it, etc." (insert generate-autoload-section-header) - (prin1 (list 'autoloads autoloads load-name file time) + (prin1 `(autoloads ,autoloads ,load-name ,file ,time) outbuf) (terpri outbuf) ;; Break that line at spaces, to avoid very long lines. @@ -317,7 +383,8 @@ which lists the file name and which functions are in it, etc." (emacs-lisp-mode) (setq default-directory (file-name-directory file)) (insert-file-contents file nil) - (let ((enable-local-variables :safe)) + (let ((enable-local-variables :safe) + (enable-local-eval nil)) (hack-local-variables)) (current-buffer))) @@ -325,7 +392,29 @@ which lists the file name and which functions are in it, etc." "File local variable to prevent scanning this file for autoload cookies.") (defun autoload-file-load-name (file) - (let ((name (file-name-nondirectory file))) + "Compute the name that will be used to load FILE." + ;; OUTFILE should be the name of the global loaddefs.el file, which + ;; is expected to be at the root directory of the files we're + ;; scanning for autoloads and will be in the `load-path'. + (let* ((outfile (default-value 'generated-autoload-file)) + (name (file-relative-name file (file-name-directory outfile))) + (names '()) + (dir (file-name-directory outfile))) + ;; If `name' has directory components, only keep the + ;; last few that are really needed. + (while name + (setq name (directory-file-name name)) + (push (file-name-nondirectory name) names) + (setq name (file-name-directory name))) + (while (not name) + (cond + ((null (cdr names)) (setq name (car names))) + ((file-exists-p (expand-file-name "subdirs.el" dir)) + ;; FIXME: here we only check the existence of subdirs.el, + ;; without checking its content. This makes it generate wrong load + ;; names for cases like lisp/term which is not added to load-path. + (setq dir (expand-file-name (pop names) dir))) + (t (setq name (mapconcat 'identity names "/"))))) (if (string-match "\\.elc?\\(\\.\\|\\'\\)" name) (substring name 0 (match-beginning 0)) name))) @@ -338,7 +427,10 @@ If FILE is being visited in a buffer, the contents of the buffer are used. Return non-nil in the case where no autoloads were added at point." (interactive "fGenerate autoloads for file: ") - (autoload-generate-file-autoloads file (current-buffer))) + (let ((generated-autoload-file buffer-file-name)) + (autoload-generate-file-autoloads file (current-buffer)))) + +(defvar print-readably) ;; When called from `generate-file-autoloads' we should ignore ;; `generated-autoload-file' altogether. When called from @@ -370,9 +462,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (visited (get-file-buffer file)) (otherbuf nil) (absfile (expand-file-name file)) - relfile ;; nil until we found a cookie. - output-start) + output-start ostart) (with-current-buffer (or visited ;; It is faster to avoid visiting the file. (autoload-find-file file)) @@ -382,7 +473,14 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (setq load-name (if (stringp generated-autoload-load-name) generated-autoload-load-name - (autoload-file-load-name file))) + (autoload-file-load-name absfile))) + (when (and outfile + (not + (if (memq system-type '(ms-dos windows-nt)) + (equal (downcase outfile) + (downcase (autoload-generated-file))) + (equal outfile (autoload-generated-file))))) + (setq otherbuf t)) (save-excursion (save-restriction (widen) @@ -393,30 +491,26 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE ((looking-at (regexp-quote generate-autoload-cookie)) ;; If not done yet, figure out where to insert this text. (unless output-start - (when (and outfile - (not (equal outfile (autoload-generated-file)))) - ;; A file-local setting of autoload-generated-file says - ;; we should ignore OUTBUF. - (setq outbuf nil) - (setq otherbuf t)) - (unless outbuf - (setq outbuf (autoload-find-destination absfile)) - (unless outbuf - ;; The file has autoload cookies, but they're - ;; already up-to-date. If OUTFILE is nil, the - ;; entries are in the expected OUTBUF, otherwise - ;; they're elsewhere. - (throw 'done outfile))) - (with-current-buffer outbuf - (setq relfile (file-relative-name absfile)) - (setq output-start (point))) - ;; (message "file=%S, relfile=%S, dest=%S" - ;; file relfile (autoload-generated-file)) - ) + (let ((outbuf + (or (if otherbuf + ;; A file-local setting of + ;; autoload-generated-file says we + ;; should ignore OUTBUF. + nil + outbuf) + (autoload-find-destination absfile load-name) + ;; The file has autoload cookies, but they're + ;; already up-to-date. If OUTFILE is nil, the + ;; entries are in the expected OUTBUF, + ;; otherwise they're elsewhere. + (throw 'done otherbuf)))) + (with-current-buffer outbuf + (setq output-start (point-marker) + ostart (point))))) (search-forward generate-autoload-cookie) (skip-chars-forward " \t") (if (eolp) - (condition-case err + (condition-case-unless-debug err ;; Read the next form and make an autoload. (let* ((form (prog1 (read (current-buffer)) (or (bolp) (forward-line 1)))) @@ -424,10 +518,12 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (if autoload (push (nth 1 form) autoloads-done) (setq autoload form)) - (let ((autoload-print-form-outbuf outbuf)) + (let ((autoload-print-form-outbuf + (marker-buffer output-start))) (autoload-print-form autoload))) (error - (message "Error in %s: %S" file err))) + (message "Autoload cookie error in %s:%s %S" + file (count-lines (point-min) (point)) err))) ;; Copy the rest of the line to the output. (princ (buffer-substring @@ -439,7 +535,7 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (forward-char 1)) (point)) (progn (forward-line 1) (point))) - outbuf))) + (marker-buffer output-start)))) ((looking-at ";") ;; Don't read the comment. (forward-line 1)) @@ -449,58 +545,69 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (when output-start (let ((secondary-autoloads-file-buf - (if (local-variable-p 'generated-autoload-file) - (current-buffer)))) - (with-current-buffer outbuf + (if otherbuf (current-buffer)))) + (with-current-buffer (marker-buffer output-start) (save-excursion ;; Insert the section-header line which lists the file name ;; and which functions are in it, etc. + (cl-assert (= ostart output-start)) (goto-char output-start) - (autoload-insert-section-header - outbuf autoloads-done load-name relfile - (if secondary-autoloads-file-buf - ;; MD5 checksums are much better because they do not - ;; change unless the file changes (so they'll be - ;; equal on two different systems and will change - ;; less often than time-stamps, thus leading to fewer - ;; unneeded changes causing spurious conflicts), but - ;; using time-stamps is a very useful optimization, - ;; so we use time-stamps for the main autoloads file - ;; (loaddefs.el) where we have special ways to - ;; circumvent the "random change problem", and MD5 - ;; checksum in secondary autoload files where we do - ;; not need the time-stamp optimization because it is - ;; already provided by the primary autoloads file. - (md5 secondary-autoloads-file-buf - ;; We'd really want to just use - ;; `emacs-internal' instead. - nil nil 'emacs-mule-unix) - (nth 5 (file-attributes relfile)))) - (insert ";;; Generated autoloads from " relfile "\n")) + (let ((relfile (file-relative-name absfile))) + (autoload-insert-section-header + (marker-buffer output-start) + autoloads-done load-name relfile + (if secondary-autoloads-file-buf + ;; MD5 checksums are much better because they do not + ;; change unless the file changes (so they'll be + ;; equal on two different systems and will change + ;; less often than time-stamps, thus leading to fewer + ;; unneeded changes causing spurious conflicts), but + ;; using time-stamps is a very useful optimization, + ;; so we use time-stamps for the main autoloads file + ;; (loaddefs.el) where we have special ways to + ;; circumvent the "random change problem", and MD5 + ;; checksum in secondary autoload files where we do + ;; not need the time-stamp optimization because it is + ;; already provided by the primary autoloads file. + (md5 secondary-autoloads-file-buf + ;; We'd really want to just use + ;; `emacs-internal' instead. + nil nil 'emacs-mule-unix) + (nth 5 (file-attributes relfile)))) + (insert ";;; Generated autoloads from " relfile "\n"))) (insert generate-autoload-section-trailer)))) (message "Generating autoloads for %s...done" file)) (or visited ;; We created this buffer, so we should kill it. (kill-buffer (current-buffer)))) - ;; If the entries were added to some other buffer, then the file - ;; doesn't add entries to OUTFILE. - (or (not output-start) otherbuf)))) + (or (not output-start) + ;; If the entries were added to some other buffer, then the file + ;; doesn't add entries to OUTFILE. + otherbuf)))) (defun autoload-save-buffers () (while autoload-modified-buffers (with-current-buffer (pop autoload-modified-buffers) - (save-buffer)))) + (let ((version-control 'never)) + (save-buffer))))) ;;;###autoload -(defun update-file-autoloads (file &optional save-after) - "Update the autoloads for FILE in `generated-autoload-file' -\(which FILE might bind in its local variables). -If SAVE-AFTER is non-nil (which is always, when called interactively), -save the buffer too. +(defun update-file-autoloads (file &optional save-after outfile) + "Update the autoloads for FILE. +If prefix arg SAVE-AFTER is non-nil, save the buffer too. + +If FILE binds `generated-autoload-file' as a file-local variable, +autoloads are written into that file. Otherwise, the autoloads +file is determined by OUTFILE. If called interactively, prompt +for OUTFILE; if called from Lisp with OUTFILE nil, use the +existing value of `generated-autoload-file'. Return FILE if there was no autoload cookie in it, else nil." - (interactive "fUpdate autoloads for file: \np") - (let* ((autoload-modified-buffers nil) + (interactive (list (read-file-name "Update autoloads for file: ") + current-prefix-arg + (read-file-name "Write autoload definitions to file: "))) + (let* ((generated-autoload-file (or outfile generated-autoload-file)) + (autoload-modified-buffers nil) (no-autoloads (autoload-generate-file-autoloads file))) (if autoload-modified-buffers (if save-after (autoload-save-buffers)) @@ -508,28 +615,23 @@ Return FILE if there was no autoload cookie in it, else nil." (message "Autoload section for %s is up to date." file))) (if no-autoloads file))) -(defun autoload-find-destination (file) +(defun autoload-find-destination (file load-name) "Find the destination point of the current buffer's autoloads. FILE is the file name of the current buffer. Returns a buffer whose point is placed at the requested location. Returns nil if the file's autoloads are uptodate, otherwise removes any prior now out-of-date autoload entries." (catch 'up-to-date - (let* ((load-name (autoload-file-load-name file)) - (buf (current-buffer)) + (let* ((buf (current-buffer)) (existing-buffer (if buffer-file-name buf)) (found nil)) - (with-current-buffer - ;; We used to use `raw-text' to read this file, but this causes - ;; problems when the file contains non-ASCII characters. - (find-file-noselect - (autoload-ensure-default-file (autoload-generated-file))) + (with-current-buffer (autoload-find-generated-file) ;; This is to make generated-autoload-file have Unix EOLs, so ;; that it is portable to all platforms. (or (eq 0 (coding-system-eol-type buffer-file-coding-system)) (set-buffer-file-coding-system 'unix)) (or (> (buffer-size) 0) - (error "Autoloads file %s does not exist" buffer-file-name)) + (error "Autoloads file %s lacks boilerplate" buffer-file-name)) (or (file-writable-p buffer-file-name) (error "Autoloads file %s is not writable" buffer-file-name)) (widen) @@ -582,20 +684,25 @@ removes any prior now out-of-date autoload entries." ;;;###autoload (defun update-directory-autoloads (&rest dirs) - "\ -Update loaddefs.el with all the current autoloads from DIRS, and no old ones. -This uses `update-file-autoloads' (which see) to do its work. -In an interactive call, you must give one argument, the name -of a single directory. In a call from Lisp, you can supply multiple + "Update autoload definitions for Lisp files in the directories DIRS. +In an interactive call, you must give one argument, the name of a +single directory. In a call from Lisp, you can supply multiple directories as separate arguments, but this usage is discouraged. The function does NOT recursively descend into subdirectories of the -directory or directories specified." +directory or directories specified. + +In an interactive call, prompt for a default output file for the +autoload definitions, and temporarily bind the variable +`generated-autoload-file' to this value. When called from Lisp, +use the existing value of `generated-autoload-file'. If any Lisp +file binds `generated-autoload-file' as a file-local variable, +write its autoloads into the specified file instead." (interactive "DUpdate autoloads from directory: ") (let* ((files-re (let ((tmp nil)) - (dolist (suf (get-load-suffixes) - (concat "^[^=.].*" (regexp-opt tmp t) "\\'")) - (unless (string-match "\\.elc" suf) (push suf tmp))))) + (dolist (suf (get-load-suffixes)) + (unless (string-match "\\.elc" suf) (push suf tmp))) + (concat "^[^=.].*" (regexp-opt tmp t) "\\'"))) (files (apply 'nconc (mapcar (lambda (dir) (directory-files (expand-file-name dir) @@ -606,13 +713,14 @@ directory or directories specified." ;; Files with no autoload cookies or whose autoloads go to other ;; files because of file-local autoload-generated-file settings. (no-autoloads nil) - (autoload-modified-buffers nil)) + (autoload-modified-buffers nil) + (generated-autoload-file + (if (called-interactively-p 'interactive) + (read-file-name "Write autoload definitions to file: ") + generated-autoload-file))) - (with-current-buffer - (find-file-noselect - (autoload-ensure-default-file (autoload-generated-file))) + (with-current-buffer (autoload-find-generated-file) (save-excursion - ;; Canonicalize file names and remove the autoload file itself. (setq files (delete (file-relative-name buffer-file-name) (mapcar 'file-relative-name files))) @@ -649,6 +757,7 @@ directory or directories specified." (t (autoload-remove-section (match-beginning 0)) (if (autoload-generate-file-autoloads + ;; Passing `current-buffer' makes it insert at point. file (current-buffer) buffer-file-name) (push file no-autoloads)))) (push file done) @@ -657,6 +766,9 @@ directory or directories specified." (dolist (file files) (cond ((member (expand-file-name file) autoload-excludes) nil) + ;; Passing nil as second argument forces + ;; autoload-generate-file-autoloads to look for the right + ;; spot where to insert each autoloads section. ((autoload-generate-file-autoloads file nil buffer-file-name) (push file no-autoloads)))) @@ -670,7 +782,8 @@ directory or directories specified." (current-buffer) nil nil no-autoloads this-time) (insert generate-autoload-section-trailer)) - (save-buffer) + (let ((version-control 'never)) + (save-buffer)) ;; In case autoload entries were added to other files because of ;; file-local autoload-generated-file settings. (autoload-save-buffers)))) @@ -678,58 +791,28 @@ directory or directories specified." (define-obsolete-function-alias 'update-autoloads-from-directories 'update-directory-autoloads "22.1") -(defvar autoload-make-program (or (getenv "MAKE") "make") - "Name of the make program in use during the Emacs build process.") - ;;;###autoload (defun batch-update-autoloads () "Update loaddefs.el autoloads in batch mode. -Calls `update-directory-autoloads' on the command line arguments." +Calls `update-directory-autoloads' on the command line arguments. +Definitions are written to `generated-autoload-file' (which +should be non-nil)." ;; For use during the Emacs build process only. + ;; Exclude those files that are preloaded on ALL platforms. + ;; These are the ones in loadup.el where "(load" is at the start + ;; of the line (crude, but it works). (unless autoload-excludes - (let* ((ldir (file-name-directory generated-autoload-file)) - (default-directory - (file-name-as-directory - (expand-file-name (if (eq system-type 'windows-nt) - "../lib-src" - "../src") ldir))) - (mfile "Makefile") - (tmpfile "echolisp.tmp") - lim) - ;; Windows uses the 'echolisp' approach because: - ;; i) It does not have $lisp as a single simple definition, so - ;; it would be harder to parse the Makefile. - ;; ii) It can, since it already has $lisp broken up into pieces - ;; that the command-line can handle. - ;; Non-Windows builds do not use the 'echolisp' approach because - ;; no-one knows (?) the maximum safe command-line length on all - ;; supported systems. $lisp is much longer there since it uses - ;; absolute paths, and it would seem a shame to split it just for this. - (when (file-readable-p mfile) - (if (eq system-type 'windows-nt) - (when (ignore-errors - (if (file-exists-p tmpfile) (delete-file tmpfile)) - ;; FIXME call-process is better, if it works. - (shell-command (format "%s echolisp > %s" - autoload-make-program tmpfile)) - (file-readable-p tmpfile)) - (with-temp-buffer - (insert-file-contents tmpfile) - ;; FIXME could be a single while loop. - (while (not (eobp)) - (setq lim (line-end-position)) - (while (re-search-forward "\\([^ ]+\\.el\\)c?\\>" lim t) - (push (expand-file-name (match-string 1)) - autoload-excludes)) - (forward-line 1)))) - (with-temp-buffer - (insert-file-contents mfile) - (when (re-search-forward "^shortlisp= " nil t) - (setq lim (line-end-position)) - (while (re-search-forward "\\.\\./lisp/\\([^ ]+\\.el\\)c?\\>" - lim t) - (push (expand-file-name (match-string 1) ldir) - autoload-excludes)))))))) + (let ((default-directory (file-name-directory generated-autoload-file)) + file) + (when (file-readable-p "loadup.el") + (with-temp-buffer + (insert-file-contents "loadup.el") + (while (re-search-forward "^(load \"\\([^\"]+\\)\"" nil t) + (setq file (match-string 1)) + (or (string-match "\\.el\\'" file) + (setq file (format "%s.el" file))) + (or (string-match "\\`site-" file) + (push (expand-file-name file) autoload-excludes))))))) (let ((args command-line-args-left)) (setq command-line-args-left nil) (apply 'update-directory-autoloads args))) diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 238a3cf2146..4481bc9ae61 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -1,13 +1,14 @@ ;;; avl-tree.el --- balanced binary trees, AVL-trees -;; Copyright (C) 1995, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2007-2013 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> -;; Inge Wallin <inge@lysator.liu.se> -;; Thomas Bellman <bellman@lysator.liu.se> +;; Inge Wallin <inge@lysator.liu.se> +;; Thomas Bellman <bellman@lysator.liu.se> +;; Toby Cubitt <toby-predictive@dr-qubit.org> ;; Maintainer: FSF ;; Created: 10 May 1991 -;; Keywords: extensions, data structures +;; Keywords: extensions, data structures, AVL, tree ;; This file is part of GNU Emacs. @@ -26,14 +27,24 @@ ;;; Commentary: -;; An AVL tree is a nearly-perfect balanced binary tree. A tree consists of -;; two elements, the root node and the compare function. The actual tree -;; has a dummy node as its root with the real root in the left pointer. +;; An AVL tree is a self-balancing binary tree. As such, inserting, +;; deleting, and retrieving data from an AVL tree containing n elements +;; is O(log n). It is somewhat more rigidly balanced than other +;; self-balancing binary trees (such as red-black trees and AA trees), +;; making insertion slightly slower, deletion somewhat slower, and +;; retrieval somewhat faster (the asymptotic scaling is of course the +;; same for all types). Thus it may be a good choice when the tree will +;; be relatively static, i.e. data will be retrieved more often than +;; they are modified. +;; +;; Internally, a tree consists of two elements, the root node and the +;; comparison function. The actual tree has a dummy node as its root +;; with the real root in the left pointer, which allows the root node to +;; be treated on a par with all other nodes. ;; ;; Each node of the tree consists of one data element, one left -;; sub-tree and one right sub-tree. Each node also has a balance -;; count, which is the difference in depth of the left and right -;; sub-trees. +;; sub-tree, one right sub-tree, and a balance count. The latter is the +;; difference in depth of the left and right sub-trees. ;; ;; The functions with names of the form "avl-tree--" are intended for ;; internal use only. @@ -42,316 +53,336 @@ (eval-when-compile (require 'cl)) -;; ================================================================ -;;; Functions and macros handling an AVL tree node. -(defstruct (avl-tree--node - ;; We force a representation without tag so it matches the - ;; pre-defstruct representation. Also we use the underlying - ;; representation in the implementation of avl-tree--node-branch. - (:type vector) - (:constructor nil) - (:constructor avl-tree--node-create (left right data balance)) - (:copier nil)) - left right data balance) -(defalias 'avl-tree--node-branch 'aref - ;; This implementation is efficient but breaks the defstruct abstraction. - ;; An alternative could be - ;; (funcall (aref [avl-tree-left avl-tree-right avl-tree-data] branch) node) - "Get value of a branch of a node. +;; ================================================================ +;;; Internal functions and macros for use in the AVL tree package -NODE is the node, and BRANCH is the branch. -0 for left pointer, 1 for right pointer and 2 for the data.\" -\(fn node branch)") -;; The funcall/aref trick doesn't work for the setf method, unless we try -;; and access the underlying setter function, but this wouldn't be -;; portable either. -(defsetf avl-tree--node-branch aset) - -;; ================================================================ -;;; Internal functions for use in the AVL tree package +;; ---------------------------------------------------------------- +;; Functions and macros handling an AVL tree. (defstruct (avl-tree- ;; A tagged list is the pre-defstruct representation. ;; (:type list) :named (:constructor nil) - (:constructor avl-tree-create (cmpfun)) + (:constructor avl-tree--create (cmpfun)) (:predicate avl-tree-p) (:copier nil)) (dummyroot (avl-tree--node-create nil nil nil 0)) cmpfun) (defmacro avl-tree--root (tree) - ;; Return the root node for an avl-tree. INTERNAL USE ONLY. - `(avl-tree--node-left (avl-tree--dummyroot tree))) + ;; Return the root node for an AVL tree. INTERNAL USE ONLY. + `(avl-tree--node-left (avl-tree--dummyroot ,tree))) + (defsetf avl-tree--root (tree) (node) `(setf (avl-tree--node-left (avl-tree--dummyroot ,tree)) ,node)) + + ;; ---------------------------------------------------------------- -;; Deleting data +;; Functions and macros handling an AVL tree node. -(defun avl-tree--del-balance1 (node branch) - ;; Rebalance a tree and return t if the height of the tree has shrunk. - (let ((br (avl-tree--node-branch node branch)) - p1 b1 p2 b2 result) - (cond - ((< (avl-tree--node-balance br) 0) - (setf (avl-tree--node-balance br) 0) - t) +(defstruct (avl-tree--node + ;; We force a representation without tag so it matches the + ;; pre-defstruct representation. Also we use the underlying + ;; representation in the implementation of + ;; avl-tree--node-branch. + (:type vector) + (:constructor nil) + (:constructor avl-tree--node-create (left right data balance)) + (:copier nil)) + left right data balance) - ((= (avl-tree--node-balance br) 0) - (setf (avl-tree--node-balance br) +1) - nil) - (t - ;; Rebalance. - (setq p1 (avl-tree--node-right br) - b1 (avl-tree--node-balance p1)) - (if (>= b1 0) - ;; Single RR rotation. - (progn - (setf (avl-tree--node-right br) (avl-tree--node-left p1)) - (setf (avl-tree--node-left p1) br) - (if (= 0 b1) - (progn - (setf (avl-tree--node-balance br) +1) - (setf (avl-tree--node-balance p1) -1) - (setq result nil)) - (setf (avl-tree--node-balance br) 0) - (setf (avl-tree--node-balance p1) 0) - (setq result t)) - (setf (avl-tree--node-branch node branch) p1) - result) - - ;; Double RL rotation. - (setq p2 (avl-tree--node-left p1) - b2 (avl-tree--node-balance p2)) - (setf (avl-tree--node-left p1) (avl-tree--node-right p2)) - (setf (avl-tree--node-right p2) p1) - (setf (avl-tree--node-right br) (avl-tree--node-left p2)) - (setf (avl-tree--node-left p2) br) - (setf (avl-tree--node-balance br) (if (> b2 0) -1 0)) - (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0)) - (setf (avl-tree--node-branch node branch) p2) - (setf (avl-tree--node-balance p2) 0) - t))))) +(defalias 'avl-tree--node-branch 'aref + ;; This implementation is efficient but breaks the defstruct + ;; abstraction. An alternative could be (funcall (aref [avl-tree-left + ;; avl-tree-right avl-tree-data] branch) node) + "Get value of a branch of a node. +NODE is the node, and BRANCH is the branch. +0 for left pointer, 1 for right pointer and 2 for the data.") -(defun avl-tree--del-balance2 (node branch) + +;; The funcall/aref trick wouldn't work for the setf method, unless we +;; tried to access the underlying setter function, but this wouldn't be +;; portable either. +(defsetf avl-tree--node-branch aset) + + + +;; ---------------------------------------------------------------- +;; Convenience macros + +(defmacro avl-tree--switch-dir (dir) + "Return opposite direction to DIR (0 = left, 1 = right)." + `(- 1 ,dir)) + +(defmacro avl-tree--dir-to-sign (dir) + "Convert direction (0,1) to sign factor (-1,+1)." + `(1- (* 2 ,dir))) + +(defmacro avl-tree--sign-to-dir (dir) + "Convert sign factor (-x,+x) to direction (0,1)." + `(if (< ,dir 0) 0 1)) + + +;; ---------------------------------------------------------------- +;; Deleting data + +(defun avl-tree--del-balance (node branch dir) + "Rebalance a tree after deleting a node. +The deletion was done from the left (DIR=0) or right (DIR=1) sub-tree of the +left (BRANCH=0) or right (BRANCH=1) child of NODE. +Return t if the height of the tree has shrunk." + ;; (or is it vice-versa for BRANCH?) (let ((br (avl-tree--node-branch node branch)) - p1 b1 p2 b2 result) + ;; opposite direction: 0,1 -> 1,0 + (opp (avl-tree--switch-dir dir)) + ;; direction 0,1 -> sign factor -1,+1 + (sgn (avl-tree--dir-to-sign dir)) + p1 b1 p2 b2) (cond - ((> (avl-tree--node-balance br) 0) + ((> (* sgn (avl-tree--node-balance br)) 0) (setf (avl-tree--node-balance br) 0) t) ((= (avl-tree--node-balance br) 0) - (setf (avl-tree--node-balance br) -1) + (setf (avl-tree--node-balance br) (- sgn)) nil) (t ;; Rebalance. - (setq p1 (avl-tree--node-left br) + (setq p1 (avl-tree--node-branch br opp) b1 (avl-tree--node-balance p1)) - (if (<= b1 0) - ;; Single LL rotation. + (if (<= (* sgn b1) 0) + ;; Single rotation. (progn - (setf (avl-tree--node-left br) (avl-tree--node-right p1)) - (setf (avl-tree--node-right p1) br) + (setf (avl-tree--node-branch br opp) + (avl-tree--node-branch p1 dir) + (avl-tree--node-branch p1 dir) br + (avl-tree--node-branch node branch) p1) (if (= 0 b1) (progn - (setf (avl-tree--node-balance br) -1) - (setf (avl-tree--node-balance p1) +1) - (setq result nil)) + (setf (avl-tree--node-balance br) (- sgn) + (avl-tree--node-balance p1) sgn) + nil) ; height hasn't changed (setf (avl-tree--node-balance br) 0) (setf (avl-tree--node-balance p1) 0) - (setq result t)) - (setf (avl-tree--node-branch node branch) p1) - result) - - ;; Double LR rotation. - (setq p2 (avl-tree--node-right p1) - b2 (avl-tree--node-balance p2)) - (setf (avl-tree--node-right p1) (avl-tree--node-left p2)) - (setf (avl-tree--node-left p2) p1) - (setf (avl-tree--node-left br) (avl-tree--node-right p2)) - (setf (avl-tree--node-right p2) br) - (setf (avl-tree--node-balance br) (if (< b2 0) +1 0)) - (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0)) - (setf (avl-tree--node-branch node branch) p2) - (setf (avl-tree--node-balance p2) 0) + t)) ; height has changed + + ;; Double rotation. + (setf p2 (avl-tree--node-branch p1 dir) + b2 (avl-tree--node-balance p2) + (avl-tree--node-branch p1 dir) + (avl-tree--node-branch p2 opp) + (avl-tree--node-branch p2 opp) p1 + (avl-tree--node-branch br opp) + (avl-tree--node-branch p2 dir) + (avl-tree--node-branch p2 dir) br + (avl-tree--node-balance br) + (if (< (* sgn b2) 0) sgn 0) + (avl-tree--node-balance p1) + (if (> (* sgn b2) 0) (- sgn) 0) + (avl-tree--node-branch node branch) p2 + (avl-tree--node-balance p2) 0) t))))) (defun avl-tree--do-del-internal (node branch q) (let ((br (avl-tree--node-branch node branch))) (if (avl-tree--node-right br) - (if (avl-tree--do-del-internal br +1 q) - (avl-tree--del-balance2 node branch)) - (setf (avl-tree--node-data q) (avl-tree--node-data br)) - (setf (avl-tree--node-branch node branch) - (avl-tree--node-left br)) + (if (avl-tree--do-del-internal br 1 q) + (avl-tree--del-balance node branch 1)) + (setf (avl-tree--node-data q) (avl-tree--node-data br) + (avl-tree--node-branch node branch) + (avl-tree--node-left br)) t))) -(defun avl-tree--do-delete (cmpfun root branch data) - ;; Return t if the height of the tree has shrunk. +(defun avl-tree--do-delete (cmpfun root branch data test nilflag) + "Delete DATA from BRANCH of node ROOT. +\(See `avl-tree-delete' for TEST and NILFLAG). + +Return cons cell (SHRUNK . DATA), where SHRUNK is t if the +height of the tree has shrunk and nil otherwise, and DATA is +the related data." (let ((br (avl-tree--node-branch root branch))) (cond + ;; DATA not in tree. ((null br) - nil) + (cons nil nilflag)) ((funcall cmpfun data (avl-tree--node-data br)) - (if (avl-tree--do-delete cmpfun br 0 data) - (avl-tree--del-balance1 root branch))) + (let ((ret (avl-tree--do-delete cmpfun br 0 data test nilflag))) + (cons (if (car ret) (avl-tree--del-balance root branch 0)) + (cdr ret)))) ((funcall cmpfun (avl-tree--node-data br) data) - (if (avl-tree--do-delete cmpfun br 1 data) - (avl-tree--del-balance2 root branch))) + (let ((ret (avl-tree--do-delete cmpfun br 1 data test nilflag))) + (cons (if (car ret) (avl-tree--del-balance root branch 1)) + (cdr ret)))) + + (t ; Found it. + ;; if it fails TEST, do nothing + (if (and test (not (funcall test (avl-tree--node-data br)))) + (cons nil nilflag) + (cond + ((null (avl-tree--node-right br)) + (setf (avl-tree--node-branch root branch) + (avl-tree--node-left br)) + (cons t (avl-tree--node-data br))) + + ((null (avl-tree--node-left br)) + (setf (avl-tree--node-branch root branch) + (avl-tree--node-right br)) + (cons t (avl-tree--node-data br))) + + (t + (if (avl-tree--do-del-internal br 0 br) + (cons (avl-tree--del-balance root branch 0) + (avl-tree--node-data br)) + (cons nil (avl-tree--node-data br)))) + )))))) - (t - ;; Found it. Let's delete it. - (cond - ((null (avl-tree--node-right br)) - (setf (avl-tree--node-branch root branch) (avl-tree--node-left br)) - t) - - ((null (avl-tree--node-left br)) - (setf (avl-tree--node-branch root branch) (avl-tree--node-right br)) - t) - (t - (if (avl-tree--do-del-internal br 0 br) - (avl-tree--del-balance1 root branch)))))))) ;; ---------------------------------------------------------------- ;; Entering data -(defun avl-tree--enter-balance1 (node branch) - ;; Rebalance a tree and return t if the height of the tree has grown. +(defun avl-tree--enter-balance (node branch dir) + "Rebalance tree after an insertion +into the left (DIR=0) or right (DIR=1) sub-tree of the +left (BRANCH=0) or right (BRANCH=1) child of NODE. +Return t if the height of the tree has grown." (let ((br (avl-tree--node-branch node branch)) - p1 p2 b2 result) + ;; opposite direction: 0,1 -> 1,0 + (opp (avl-tree--switch-dir dir)) + ;; direction 0,1 -> sign factor -1,+1 + (sgn (avl-tree--dir-to-sign dir)) + p1 p2 b2) (cond - ((< (avl-tree--node-balance br) 0) + ((< (* sgn (avl-tree--node-balance br)) 0) (setf (avl-tree--node-balance br) 0) nil) ((= (avl-tree--node-balance br) 0) - (setf (avl-tree--node-balance br) +1) + (setf (avl-tree--node-balance br) sgn) t) (t ;; Tree has grown => Rebalance. - (setq p1 (avl-tree--node-right br)) - (if (> (avl-tree--node-balance p1) 0) - ;; Single RR rotation. + (setq p1 (avl-tree--node-branch br dir)) + (if (> (* sgn (avl-tree--node-balance p1)) 0) + ;; Single rotation. (progn - (setf (avl-tree--node-right br) (avl-tree--node-left p1)) - (setf (avl-tree--node-left p1) br) + (setf (avl-tree--node-branch br dir) + (avl-tree--node-branch p1 opp)) + (setf (avl-tree--node-branch p1 opp) br) (setf (avl-tree--node-balance br) 0) (setf (avl-tree--node-branch node branch) p1)) - ;; Double RL rotation. - (setq p2 (avl-tree--node-left p1) - b2 (avl-tree--node-balance p2)) - (setf (avl-tree--node-left p1) (avl-tree--node-right p2)) - (setf (avl-tree--node-right p2) p1) - (setf (avl-tree--node-right br) (avl-tree--node-left p2)) - (setf (avl-tree--node-left p2) br) - (setf (avl-tree--node-balance br) (if (> b2 0) -1 0)) - (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0)) - (setf (avl-tree--node-branch node branch) p2)) - (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0) + ;; Double rotation. + (setf p2 (avl-tree--node-branch p1 opp) + b2 (avl-tree--node-balance p2) + (avl-tree--node-branch p1 opp) + (avl-tree--node-branch p2 dir) + (avl-tree--node-branch p2 dir) p1 + (avl-tree--node-branch br dir) + (avl-tree--node-branch p2 opp) + (avl-tree--node-branch p2 opp) br + (avl-tree--node-balance br) + (if (> (* sgn b2) 0) (- sgn) 0) + (avl-tree--node-balance p1) + (if (< (* sgn b2) 0) sgn 0) + (avl-tree--node-branch node branch) p2)) + (setf (avl-tree--node-balance + (avl-tree--node-branch node branch)) 0) nil)))) -(defun avl-tree--enter-balance2 (node branch) - ;; Return t if the tree has grown. - (let ((br (avl-tree--node-branch node branch)) - p1 p2 b2) - (cond - ((> (avl-tree--node-balance br) 0) - (setf (avl-tree--node-balance br) 0) - nil) - - ((= (avl-tree--node-balance br) 0) - (setf (avl-tree--node-balance br) -1) - t) - - (t - ;; Balance was -1 => Rebalance. - (setq p1 (avl-tree--node-left br)) - (if (< (avl-tree--node-balance p1) 0) - ;; Single LL rotation. - (progn - (setf (avl-tree--node-left br) (avl-tree--node-right p1)) - (setf (avl-tree--node-right p1) br) - (setf (avl-tree--node-balance br) 0) - (setf (avl-tree--node-branch node branch) p1)) +(defun avl-tree--do-enter (cmpfun root branch data &optional updatefun) + "Enter DATA in BRANCH of ROOT node. +\(See `avl-tree-enter' for UPDATEFUN). - ;; Double LR rotation. - (setq p2 (avl-tree--node-right p1) - b2 (avl-tree--node-balance p2)) - (setf (avl-tree--node-right p1) (avl-tree--node-left p2)) - (setf (avl-tree--node-left p2) p1) - (setf (avl-tree--node-left br) (avl-tree--node-right p2)) - (setf (avl-tree--node-right p2) br) - (setf (avl-tree--node-balance br) (if (< b2 0) +1 0)) - (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0)) - (setf (avl-tree--node-branch node branch) p2)) - (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0) - nil)))) - -(defun avl-tree--do-enter (cmpfun root branch data) - ;; Return t if height of tree ROOT has grown. INTERNAL USE ONLY. +Return cons cell (GREW . DATA), where GREW is t if height +of tree ROOT has grown and nil otherwise, and DATA is the +inserted data." (let ((br (avl-tree--node-branch root branch))) (cond ((null br) ;; Data not in tree, insert it. (setf (avl-tree--node-branch root branch) (avl-tree--node-create nil nil data 0)) - t) + (cons t data)) ((funcall cmpfun data (avl-tree--node-data br)) - (and (avl-tree--do-enter cmpfun br 0 data) - (avl-tree--enter-balance2 root branch))) + (let ((ret (avl-tree--do-enter cmpfun br 0 data updatefun))) + (cons (and (car ret) (avl-tree--enter-balance root branch 0)) + (cdr ret)))) ((funcall cmpfun (avl-tree--node-data br) data) - (and (avl-tree--do-enter cmpfun br 1 data) - (avl-tree--enter-balance1 root branch))) + (let ((ret (avl-tree--do-enter cmpfun br 1 data updatefun))) + (cons (and (car ret) (avl-tree--enter-balance root branch 1)) + (cdr ret)))) + ;; Data already in tree, update it. (t - (setf (avl-tree--node-data br) data) - nil)))) + (let ((newdata + (if updatefun + (funcall updatefun data (avl-tree--node-data br)) + data))) + (if (or (funcall cmpfun newdata data) + (funcall cmpfun data newdata)) + (error "avl-tree-enter:\ + updated data does not match existing data")) + (setf (avl-tree--node-data br) newdata) + (cons nil newdata)) ; return value + )))) + +(defun avl-tree--check (tree) + "Check the tree's balance." + (avl-tree--check-node (avl-tree--root tree))) +(defun avl-tree--check-node (node) + (if (null node) 0 + (let ((dl (avl-tree--check-node (avl-tree--node-left node))) + (dr (avl-tree--check-node (avl-tree--node-right node)))) + (assert (= (- dr dl) (avl-tree--node-balance node))) + (1+ (max dl dr))))) ;; ---------------------------------------------------------------- -(defun avl-tree--mapc (map-function root) - ;; Apply MAP-FUNCTION to all nodes in the tree starting with ROOT. - ;; The function is applied in-order. - ;; - ;; Note: MAP-FUNCTION is applied to the node and not to the data itself. - ;; INTERNAL USE ONLY. + +;;; INTERNAL USE ONLY +(defun avl-tree--mapc (map-function root dir) + "Apply MAP-FUNCTION to all nodes in the tree starting with ROOT. +The function is applied in-order, either ascending (DIR=0) or +descending (DIR=1). + +Note: MAP-FUNCTION is applied to the node and not to the data +itself." (let ((node root) (stack nil) - (go-left t)) + (go-dir t)) (push nil stack) (while node - (if (and go-left - (avl-tree--node-left node)) - ;; Do the left subtree first. + (if (and go-dir + (avl-tree--node-branch node dir)) + ;; Do the DIR subtree first. (progn (push node stack) - (setq node (avl-tree--node-left node))) + (setq node (avl-tree--node-branch node dir))) ;; Apply the function... (funcall map-function node) - ;; and do the right subtree. - (setq node (if (setq go-left (avl-tree--node-right node)) - (avl-tree--node-right node) + ;; and do the opposite subtree. + (setq node (if (setq go-dir (avl-tree--node-branch + node (avl-tree--switch-dir dir))) + (avl-tree--node-branch + node (avl-tree--switch-dir dir)) (pop stack))))))) +;;; INTERNAL USE ONLY (defun avl-tree--do-copy (root) - ;; Copy the avl tree with ROOT as root. - ;; Highly recursive. INTERNAL USE ONLY. + "Copy the AVL tree with ROOT as root. Highly recursive." (if (null root) nil (avl-tree--node-create @@ -360,66 +391,185 @@ NODE is the node, and BRANCH is the branch. (avl-tree--node-data root) (avl-tree--node-balance root)))) - +(defstruct (avl-tree--stack + (:constructor nil) + (:constructor avl-tree--stack-create + (tree &optional reverse + &aux + (store + (if (avl-tree-empty tree) + nil + (list (avl-tree--root tree)))))) + (:copier nil)) + reverse store) + +(defalias 'avl-tree-stack-p 'avl-tree--stack-p + "Return t if argument is an avl-tree-stack, nil otherwise.") + +(defun avl-tree--stack-repopulate (stack) + ;; Recursively push children of the node at the head of STACK onto the + ;; front of the STACK, until a leaf is reached. + (let ((node (car (avl-tree--stack-store stack))) + (dir (if (avl-tree--stack-reverse stack) 1 0))) + (when node ; check for empty stack + (while (setq node (avl-tree--node-branch node dir)) + (push node (avl-tree--stack-store stack)))))) + + ;; ================================================================ ;;; The public functions which operate on AVL trees. +;; define public alias for constructors so that we can set docstring +(defalias 'avl-tree-create 'avl-tree--create + "Create an empty AVL tree. +COMPARE-FUNCTION is a function which takes two arguments, A and B, +and returns non-nil if A is less than B, and nil otherwise.") + (defalias 'avl-tree-compare-function 'avl-tree--cmpfun - "Return the comparison function for the avl tree TREE. + "Return the comparison function for the AVL tree TREE. \(fn TREE)") (defun avl-tree-empty (tree) - "Return t if avl tree TREE is emtpy, otherwise return nil." + "Return t if AVL tree TREE is empty, otherwise return nil." (null (avl-tree--root tree))) -(defun avl-tree-enter (tree data) - "In the avl tree TREE insert DATA. -Return DATA." - (avl-tree--do-enter (avl-tree--cmpfun tree) - (avl-tree--dummyroot tree) - 0 - data) - data) - -(defun avl-tree-delete (tree data) - "From the avl tree TREE, delete DATA. -Return the element in TREE which matched DATA, -nil if no element matched." - (avl-tree--do-delete (avl-tree--cmpfun tree) - (avl-tree--dummyroot tree) - 0 - data)) - -(defun avl-tree-member (tree data) - "Return the element in the avl tree TREE which matches DATA. -Matching uses the compare function previously specified in +(defun avl-tree-enter (tree data &optional updatefun) + "Insert DATA into the AVL tree TREE. + +If an element that matches DATA (according to the tree's +comparison function, see `avl-tree-create') already exists in +TREE, it will be replaced by DATA by default. + +If UPDATEFUN is supplied and an element matching DATA already +exists in TREE, UPDATEFUN is called with two arguments: DATA, and +the matching element. Its return value replaces the existing +element. This value *must* itself match DATA (and hence the +pre-existing data), or an error will occur. + +Returns the new data." + (cdr (avl-tree--do-enter (avl-tree--cmpfun tree) + (avl-tree--dummyroot tree) + 0 data updatefun))) + +(defun avl-tree-delete (tree data &optional test nilflag) + "Delete the element matching DATA from the AVL tree TREE. +Matching uses the comparison function previously specified in +`avl-tree-create' when TREE was created. + +Returns the deleted element, or nil if no matching element was +found. + +Optional argument NILFLAG specifies a value to return instead of +nil if nothing was deleted, so that this case can be +distinguished from the case of a successfully deleted null +element. + +If supplied, TEST specifies a test that a matching element must +pass before it is deleted. If a matching element is found, it is +passed as an argument to TEST, and is deleted only if the return +value is non-nil." + (cdr (avl-tree--do-delete (avl-tree--cmpfun tree) + (avl-tree--dummyroot tree) + 0 data test nilflag))) + + +(defun avl-tree-member (tree data &optional nilflag) + "Return the element in the AVL tree TREE which matches DATA. +Matching uses the comparison function previously specified in `avl-tree-create' when TREE was created. -If there is no such element in the tree, the value is nil." +If there is no such element in the tree, nil is +returned. Optional argument NILFLAG specifies a value to return +instead of nil in this case. This allows non-existent elements to +be distinguished from a null element. (See also +`avl-tree-member-p', which does this for you.)" (let ((node (avl-tree--root tree)) - (compare-function (avl-tree--cmpfun tree)) - found) - (while (and node - (not found)) - (cond - ((funcall compare-function data (avl-tree--node-data node)) - (setq node (avl-tree--node-left node))) - ((funcall compare-function (avl-tree--node-data node) data) - (setq node (avl-tree--node-right node))) - (t - (setq found t)))) - (if node - (avl-tree--node-data node) - nil))) - -(defun avl-tree-map (__map-function__ tree) - "Apply __MAP-FUNCTION__ to all elements in the avl tree TREE." + (compare-function (avl-tree--cmpfun tree))) + (catch 'found + (while node + (cond + ((funcall compare-function data (avl-tree--node-data node)) + (setq node (avl-tree--node-left node))) + ((funcall compare-function (avl-tree--node-data node) data) + (setq node (avl-tree--node-right node))) + (t (throw 'found (avl-tree--node-data node))))) + nilflag))) + + +(defun avl-tree-member-p (tree data) + "Return t if an element matching DATA exists in the AVL tree TREE. +Otherwise return nil. Matching uses the comparison function +previously specified in `avl-tree-create' when TREE was created." + (let ((flag '(nil))) + (not (eq (avl-tree-member tree data flag) flag)))) + + +(defun avl-tree-map (__map-function__ tree &optional reverse) + "Modify all elements in the AVL tree TREE by applying FUNCTION. + +Each element is replaced by the return value of FUNCTION applied +to that element. + +FUNCTION is applied to the elements in ascending order, or +descending order if REVERSE is non-nil." (avl-tree--mapc (lambda (node) (setf (avl-tree--node-data node) (funcall __map-function__ (avl-tree--node-data node)))) - (avl-tree--root tree))) + (avl-tree--root tree) + (if reverse 1 0))) + + +(defun avl-tree-mapc (__map-function__ tree &optional reverse) + "Apply FUNCTION to all elements in AVL tree TREE, +for side-effect only. + +FUNCTION is applied to the elements in ascending order, or +descending order if REVERSE is non-nil." + (avl-tree--mapc + (lambda (node) + (funcall __map-function__ (avl-tree--node-data node))) + (avl-tree--root tree) + (if reverse 1 0))) + + +(defun avl-tree-mapf + (__map-function__ combinator tree &optional reverse) + "Apply FUNCTION to all elements in AVL tree TREE, +and combine the results using COMBINATOR. + +The FUNCTION is applied and the results are combined in ascending +order, or descending order if REVERSE is non-nil." + (let (avl-tree-mapf--accumulate) + (avl-tree--mapc + (lambda (node) + (setq avl-tree-mapf--accumulate + (funcall combinator + (funcall __map-function__ + (avl-tree--node-data node)) + avl-tree-mapf--accumulate))) + (avl-tree--root tree) + (if reverse 0 1)) + (nreverse avl-tree-mapf--accumulate))) + + +(defun avl-tree-mapcar (__map-function__ tree &optional reverse) + "Apply FUNCTION to all elements in AVL tree TREE, +and make a list of the results. + +The FUNCTION is applied and the list constructed in ascending +order, or descending order if REVERSE is non-nil. + +Note that if you don't care about the order in which FUNCTION is +applied, just that the resulting list is in the correct order, +then + + (avl-tree-mapf function 'cons tree (not reverse)) + +is more efficient." + (nreverse (avl-tree-mapf __map-function__ 'cons tree reverse))) + (defun avl-tree-first (tree) "Return the first element in TREE, or nil if TREE is empty." @@ -438,33 +588,90 @@ If there is no such element in the tree, the value is nil." (avl-tree--node-data node)))) (defun avl-tree-copy (tree) - "Return a copy of the avl tree TREE." + "Return a copy of the AVL tree TREE." (let ((new-tree (avl-tree-create (avl-tree--cmpfun tree)))) (setf (avl-tree--root new-tree) (avl-tree--do-copy (avl-tree--root tree))) new-tree)) (defun avl-tree-flatten (tree) "Return a sorted list containing all elements of TREE." - (nreverse (let ((treelist nil)) (avl-tree--mapc (lambda (node) (push (avl-tree--node-data node) treelist)) - (avl-tree--root tree)) - treelist))) + (avl-tree--root tree) 1) + treelist)) (defun avl-tree-size (tree) "Return the number of elements in TREE." (let ((treesize 0)) (avl-tree--mapc (lambda (data) (setq treesize (1+ treesize))) - (avl-tree--root tree)) + (avl-tree--root tree) 0) treesize)) (defun avl-tree-clear (tree) - "Clear the avl tree TREE." + "Clear the AVL tree TREE." (setf (avl-tree--root tree) nil)) + +(defun avl-tree-stack (tree &optional reverse) + "Return an object that behaves like a sorted stack +of all elements of TREE. + +If REVERSE is non-nil, the stack is sorted in reverse order. +\(See also `avl-tree-stack-pop'\). + +Note that any modification to TREE *immediately* invalidates all +avl-tree-stacks created before the modification (in particular, +calling `avl-tree-stack-pop' will give unpredictable results). + +Operations on these objects are significantly more efficient than +constructing a real stack with `avl-tree-flatten' and using +standard stack functions. As such, they can be useful in +implementing efficient algorithms of AVL trees. However, in cases +where mapping functions `avl-tree-mapc', `avl-tree-mapcar' or +`avl-tree-mapf' would be sufficient, it is better to use one of +those instead." + (let ((stack (avl-tree--stack-create tree reverse))) + (avl-tree--stack-repopulate stack) + stack)) + + +(defun avl-tree-stack-pop (avl-tree-stack &optional nilflag) + "Pop the first element from AVL-TREE-STACK. +\(See also `avl-tree-stack'). + +Returns nil if the stack is empty, or NILFLAG if specified. +\(The latter allows an empty stack to be distinguished from +a null element stored in the AVL tree.)" + (let (node next) + (if (not (setq node (pop (avl-tree--stack-store avl-tree-stack)))) + nilflag + (when (setq next + (avl-tree--node-branch + node + (if (avl-tree--stack-reverse avl-tree-stack) 0 1))) + (push next (avl-tree--stack-store avl-tree-stack)) + (avl-tree--stack-repopulate avl-tree-stack)) + (avl-tree--node-data node)))) + + +(defun avl-tree-stack-first (avl-tree-stack &optional nilflag) + "Return the first element of AVL-TREE-STACK, without removing it +from the stack. + +Returns nil if the stack is empty, or NILFLAG if specified. +\(The latter allows an empty stack to be distinguished from +a null element stored in the AVL tree.)" + (or (car (avl-tree--stack-store avl-tree-stack)) + nilflag)) + + +(defun avl-tree-stack-empty-p (avl-tree-stack) + "Return t if AVL-TREE-STACK is empty, nil otherwise." + (null (avl-tree--stack-store avl-tree-stack))) + + (provide 'avl-tree) -;; arch-tag: 47e26701-43c9-4222-bd79-739eac6357a9 ;;; avl-tree.el ends here diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index 6d72b98c719..2dc84e9ddfb 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -1,11 +1,12 @@ ;;; backquote.el --- implement the ` Lisp construct -;; Copyright (C) 1990, 1992, 1994, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1990, 1992, 1994, 2001-2013 Free Software Foundation, +;; Inc. ;; Author: Rick Sladkey <jrs@world.std.com> ;; Maintainer: FSF ;; Keywords: extensions, internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -240,5 +241,4 @@ LEVEL is only used internally and indicates the nesting level: tail)) (t (cons 'list heads))))) -;; arch-tag: 1a26206a-6b5e-4c56-8e24-2eef0f7e0e7a ;;; backquote.el ends here diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 032dfd98f35..c97b33f4e7d 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -1,7 +1,6 @@ ;;; benchmark.el --- support for benchmarking code -;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 2003-2013 Free Software Foundation, Inc. ;; Author: Dave Love <fx@gnu.org> ;; Keywords: lisp, extensions @@ -40,9 +39,8 @@ (setq ,t1 (current-time)) ,@forms (setq ,t2 (current-time)) - (+ (* (- (car ,t2) (car ,t1)) 65536.0) - (- (nth 1 ,t2) (nth 1 ,t1)) - (* (- (nth 2 ,t2) (nth 2 ,t1)) 1.0e-6))))) + (float-time (time-subtract ,t2 ,t1))))) + (put 'benchmark-elapse 'edebug-form-spec t) (put 'benchmark-elapse 'lisp-indent-function 0) @@ -55,6 +53,7 @@ FORMS once. Return a list of the total elapsed time for execution, the number of garbage collections that ran, and the time taken by garbage collection. See also `benchmark-run-compiled'." + (declare (indent 1) (debug t)) (unless (natnump repetitions) (setq forms (cons repetitions forms) repetitions 1)) @@ -71,8 +70,6 @@ See also `benchmark-run-compiled'." `(benchmark-elapse ,@forms)) (- gcs-done ,gcs) (- gc-elapsed ,gc))))) -(put 'benchmark-run 'edebug-form-spec t) -(put 'benchmark-run 'lisp-indent-function 2) ;;;###autoload (defmacro benchmark-run-compiled (&optional repetitions &rest forms) @@ -80,6 +77,7 @@ See also `benchmark-run-compiled'." This is like `benchmark-run', but what is timed is a funcall of the byte code obtained by wrapping FORMS in a `lambda' and compiling the result. The overhead of the `lambda's is accounted for." + (declare (indent 1) (debug t)) (unless (natnump repetitions) (setq forms (cons repetitions forms) repetitions 1)) @@ -98,8 +96,6 @@ result. The overhead of the `lambda's is accounted for." (funcall ,lambda-code)))) `(benchmark-elapse (funcall ,code))) (- gcs-done ,gcs) (- gc-elapsed ,gc))))) -(put 'benchmark-run-compiled 'edebug-form-spec t) -(put 'benchmark-run-compiled 'lisp-indent-function 2) ;;;###autoload (defun benchmark (repetitions form) @@ -116,5 +112,4 @@ For non-interactive use see also `benchmark-run' and (provide 'benchmark) -;; arch-tag: be570e24-4b51-4784-adf3-fa2b56c31946 ;;; benchmark.el ends here diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 459957a26f6..86d72fef9b5 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -1,6 +1,6 @@ ;;; bindat.el --- binary data structure packing and unpacking. -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Author: Kim F. Storm <storm@cua.dk> ;; Assignment name: struct.el @@ -649,5 +649,4 @@ The port (if any) is omitted. IP can be a string, as well." (provide 'bindat) -;; arch-tag: 5e6708c3-03e2-4ad7-9885-5041b779c3fb ;;; bindat.el ends here diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index ee0466fecc8..0ddc78242ac 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1,12 +1,12 @@ -;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler +;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*- -;; Copyright (C) 1991, 1994, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1994, 2000-2013 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -135,7 +135,7 @@ ;; 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 +;; But! We need to know about variables that were not necessarily defvared ;; 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. ;; @@ -183,11 +183,14 @@ ;;; Code: (require 'bytecomp) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) +(require 'macroexp) (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")) + ;; Newer byte codes for stack-ref make the slot 0 non-nil again. + ;; But the "old disassembler" is *really* ancient by now. + ;; (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) @@ -242,58 +245,64 @@ 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 - (when (and (consp fn) (eq (car fn) 'autoload)) - (load (nth 1 fn)) - (setq fn (or (and (fboundp name) (symbol-function name)) - (cdr (assq name byte-compile-function-environment))))) - (if (and (consp fn) (eq (car fn) 'autoload)) - (error "File `%s' didn't define `%s'" (nth 1 fn) name)) - (if (and (symbolp fn) (not (eq fn t))) - (byte-compile-inline-expand (cons fn (cdr form))) - (if (byte-code-function-p fn) - (let (string) - (fetch-bytecode fn) - (setq string (aref fn 1)) - ;; Isn't it an error for `string' not to be unibyte?? --stef - (if (fboundp 'string-as-unibyte) - (setq string (string-as-unibyte string))) - ;; `byte-compile-splice-in-already-compiled-code' - ;; takes care of inlining the body. - (cons `(lambda ,(aref fn 0) - (byte-code ,string ,(aref fn 2) ,(aref fn 3))) - (cdr form))) - (if (eq (car-safe fn) 'lambda) - (cons fn (cdr form)) - ;; Give up on inlining. - form)))))) + (localfn (cdr (assq name byte-compile-function-environment))) + (fn (or localfn (and (fboundp name) (symbol-function name))))) + (when (autoloadp fn) + (autoload-do-load fn) + (setq fn (or (and (fboundp name) (symbol-function name)) + (cdr (assq name byte-compile-function-environment))))) + (pcase fn + (`nil + (byte-compile-warn "attempt to inline `%s' before it was defined" + name) + form) + (`(autoload . ,_) + (error "File `%s' didn't define `%s'" (nth 1 fn) name)) + ((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias. + (byte-compile-inline-expand (cons fn (cdr form)))) + ((pred byte-code-function-p) + ;; (message "Inlining byte-code for %S!" name) + ;; The byte-code will be really inlined in byte-compile-unfold-bcf. + `(,fn ,@(cdr form))) + ((or `(lambda . ,_) `(closure . ,_)) + (if (not (or (eq fn localfn) ;From the same file => same mode. + (eq (car fn) ;Same mode. + (if lexical-binding 'closure 'lambda)))) + ;; While byte-compile-unfold-bcf can inline dynbind byte-code into + ;; letbind byte-code (or any other combination for that matter), we + ;; can only inline dynbind source into dynbind source or letbind + ;; source into letbind source. + (progn + ;; We can of course byte-compile the inlined function + ;; first, and then inline its byte-code. + (byte-compile name) + `(,(symbol-function name) ,@(cdr form))) + (let ((newfn (if (eq fn localfn) + ;; If `fn' is from the same file, it has already + ;; been preprocessed! + `(function ,fn) + (byte-compile-preprocess + (byte-compile--reify-function fn))))) + (if (eq (car-safe newfn) 'function) + (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) + (byte-compile-log-warning + (format "Inlining closure %S failed" name)) + form)))) + + (t ;; Give up on inlining. + form)))) ;; ((lambda ...) ...) (defun byte-compile-unfold-lambda (form &optional name) + ;; In lexical-binding mode, let and functions don't bind vars in the same way + ;; (let obey special-variable-p, but functions don't). But luckily, this + ;; doesn't matter here, because function's behavior is underspecified so it + ;; can safely be turned into a `let', even though the reverse is not true. (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 @@ -302,6 +311,7 @@ (setq body (cdr body))) (if (and (consp (car body)) (eq 'interactive (car (car body)))) (setq body (cdr body))) + ;; FIXME: The checks below do not belong in an optimization phase. (while arglist (cond ((eq (car arglist) '&optional) ;; ok, I'll let this slide because funcall_lambda() does... @@ -379,8 +389,7 @@ (and (nth 1 form) (not for-effect) form)) - ((or (byte-code-function-p fn) - (eq 'lambda (car-safe fn))) + ((eq 'lambda (car-safe fn)) (let ((newform (byte-compile-unfold-lambda form))) (if (eq newform form) ;; Some error occurred, avoid infinite recursion @@ -414,11 +423,9 @@ clause)) (cdr form)))) ((eq fn 'progn) - ;; as an extra added bonus, this simplifies (progn <x>) --> <x> + ;; 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))) + (macroexp-progn (byte-optimize-body (cdr form) for-effect)) (byte-optimize-form (nth 1 form) for-effect))) ((eq fn 'prog1) (if (cdr (cdr form)) @@ -455,8 +462,8 @@ (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. + ((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. @@ -471,7 +478,8 @@ (byte-compile-log " all subforms of %s called for effect; deleted" form)) (and backwards - (cons fn (nreverse (mapcar 'byte-optimize-form backwards))))) + (cons fn (nreverse (mapcar 'byte-optimize-form + backwards))))) (cons fn (mapcar 'byte-optimize-form (cdr form))))) ((eq fn 'interactive) @@ -479,8 +487,7 @@ (prin1-to-string form)) nil) - ((memq fn '(defun defmacro function - condition-case save-window-excursion)) + ((memq fn '(function condition-case)) ;; These forms are compiled as constants or by breaking out ;; all the subexpressions and compiling them separately. form) @@ -511,23 +518,11 @@ ;; However, don't actually bother calling `ignore'. `(prog1 nil . ,(mapcar 'byte-optimize-form (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)) - - ;; Support compiler macros as in cl.el. - ((and (fboundp 'compiler-macroexpand) - (symbolp (car-safe form)) - (get (car-safe form) 'cl-compiler-macro) - (not (eq form - (with-no-warnings - (setq form (compiler-macroexpand form)))))) - (byte-optimize-form form for-effect)) + ;; Needed as long as we run byte-optimize-form after cconv. + ((eq fn 'internal-make-closure) form) + + ((byte-code-function-p fn) + (cons fn (mapcar #'byte-optimize-form (cdr form)))) ((not (symbolp fn)) (byte-compile-warn "`%s' is a malformed function" @@ -569,10 +564,10 @@ (cons fn args))))))) (defun byte-optimize-all-constp (list) - "Non-nil if all elements of LIST satisfy `byte-compile-constp'." + "Non-nil if all elements of LIST satisfy `macroexp-const-p" (let ((constant t)) (while (and list constant) - (unless (byte-compile-constp (car list)) + (unless (macroexp-const-p (car list)) (setq constant nil)) (setq list (cdr list))) constant)) @@ -591,10 +586,11 @@ (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))) + (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 (function-get (car form) 'byte-optimizer))) (not (eq form (setq new (funcall opt form))))) (progn ;; (if (equal form new) (error "bogus optimizer -- %s" opt)) @@ -605,7 +601,7 @@ (defun byte-optimize-body (forms all-for-effect) - ;; optimize the cdr of a progn or implicit progn; all forms is a list of + ;; 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. @@ -635,10 +631,10 @@ (while (eq (car-safe form) 'progn) (setq form (car (last (cdr form))))) (cond ((consp form) - (case (car form) - (quote (cadr form)) + (pcase (car form) + (`quote (cadr form)) ;; Can't use recursion in a defsubst. - ;; (progn (byte-compile-trueconstp (car (last (cdr form))))) + ;; (`progn (byte-compile-trueconstp (car (last (cdr form))))) )) ((not (symbolp form))) ((eq form t)) @@ -649,10 +645,10 @@ (while (eq (car-safe form) 'progn) (setq form (car (last (cdr form))))) (cond ((consp form) - (case (car form) - (quote (null (cadr form))) + (pcase (car form) + (`quote (null (cadr form))) ;; Can't use recursion in a defsubst. - ;; (progn (byte-compile-nilconstp (car (last (cdr form))))) + ;; (`progn (byte-compile-nilconstp (car (last (cdr form))))) )) ((not (symbolp form)) nil) ((null form)))) @@ -862,8 +858,8 @@ (defun byte-optimize-binary-predicate (form) - (if (byte-compile-constp (nth 1 form)) - (if (byte-compile-constp (nth 2 form)) + (if (macroexp-const-p (nth 1 form)) + (if (macroexp-const-p (nth 2 form)) (condition-case () (list 'quote (eval form)) (error form)) @@ -875,7 +871,7 @@ (let ((ok t) (rest (cdr form))) (while (and rest ok) - (setq ok (byte-compile-constp (car rest)) + (setq ok (macroexp-const-p (car rest)) rest (cdr rest))) (if ok (condition-case () @@ -941,7 +937,7 @@ (defun byte-optimize-quote (form) (if (or (consp (nth 1 form)) (and (symbolp (nth 1 form)) - (not (byte-compile-const-symbol-p form)))) + (not (macroexp--const-symbol-p form)))) form (nth 1 form))) @@ -1085,7 +1081,7 @@ (let ((fn (nth 1 form))) (if (memq (car-safe fn) '(quote function)) (cons (nth 1 fn) (cdr (cdr form))) - form))) + form))) (defun byte-optimize-apply (form) ;; If the last arg is a literal constant, turn this into a funcall. @@ -1151,16 +1147,6 @@ ;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte, ;; string-make-multibyte for constant args. -(put 'featurep 'byte-optimizer 'byte-optimize-featurep) -(defun byte-optimize-featurep (form) - ;; Emacs-21's byte-code doesn't run under XEmacs or SXEmacs anyway, so we - ;; can safely optimize away this test. - (if (member (cdr-safe form) '(((quote xemacs)) ((quote sxemacs)))) - nil - (if (member (cdr-safe form) '(((quote emacs)))) - t - form))) - (put 'set 'byte-optimizer 'byte-optimize-set) (defun byte-optimize-set (form) (let ((var (car-safe (cdr-safe form)))) @@ -1233,7 +1219,7 @@ string-to-multibyte tan truncate unibyte-char-to-multibyte upcase user-full-name - user-login-name user-original-login-name user-variable-p + user-login-name user-original-login-name custom-variable-p vconcat window-buffer window-dedicated-p window-edges window-height window-hscroll window-minibuffer-p window-width @@ -1291,60 +1277,51 @@ (put (car pure-fns) 'pure t) (setq pure-fns (cdr pure-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)) +;; Used and set dynamically in byte-decompile-bytecode-1. +(defvar bytedecomp-op) +(defvar bytedecomp-ptr) + ;; This function extracts the bitfields from variable-length opcodes. ;; Originally defined in disass.el (which no longer uses it.) - -(defun disassemble-offset () +(defun disassemble-offset (bytes) "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)) + ;; Fetch and return the offset for the current opcode. + ;; Return nil if this opcode has no offset. + (cond ((< bytedecomp-op byte-nth) + (let ((tem (logand bytedecomp-op 7))) + (setq bytedecomp-op (logand bytedecomp-op 248)) (cond ((eq tem 6) - (setq ptr (1+ ptr)) ;offset in next byte - (aref bytes ptr)) + ;; Offset in next byte. + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (aref bytes bytedecomp-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)))) - + ;; Offset in next 2 bytes. + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (+ (aref bytes bytedecomp-ptr) + (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (lsh (aref bytes bytedecomp-ptr) 8)))) + (t tem)))) ;Offset was in opcode. + ((>= bytedecomp-op byte-constant) + (prog1 (- bytedecomp-op byte-constant) ;Offset in opcode. + (setq bytedecomp-op byte-constant))) + ((or (and (>= bytedecomp-op byte-constant2) + (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) + (= bytedecomp-op byte-stack-set2)) + ;; Offset in next 2 bytes. + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (+ (aref bytes bytedecomp-ptr) + (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (lsh (aref bytes bytedecomp-ptr) 8)))) + ((and (>= bytedecomp-op byte-listN) + (<= bytedecomp-op byte-discardN)) + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte. + (aref bytes bytedecomp-ptr)))) + +(defvar byte-compile-tag-number) ;; This de-compiler is used for inline expansion of compiled functions, ;; and by the disassembler. @@ -1368,62 +1345,62 @@ ;; before each insn (or its label). (defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) (let ((length (length bytes)) - (ptr 0) optr tags op offset - lap tmp - endtag) - (while (not (= ptr length)) + (bytedecomp-ptr 0) optr tags bytedecomp-op offset + lap tmp) + (while (not (= bytedecomp-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 + (push bytedecomp-ptr lap)) + (setq bytedecomp-op (aref bytes bytedecomp-ptr) + optr bytedecomp-ptr + ;; This uses dynamic-scope magic. + offset (disassemble-offset bytes)) + (let ((opcode (aref byte-code-vector bytedecomp-op))) + (cl-assert opcode) + (setq bytedecomp-op opcode)) + (cond ((memq bytedecomp-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))) + (let ((new (cons offset (byte-compile-make-tag)))) + (push new tags) + new))))) + ((cond ((eq bytedecomp-op 'byte-constant2) + (setq bytedecomp-op 'byte-constant) t) + ((memq bytedecomp-op byte-constref-ops))) (setq tmp (if (>= offset (length constvec)) (list 'out-of-range offset) (aref constvec offset)) - offset (if (eq op 'byte-constant) + offset (if (eq bytedecomp-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)))) + (let ((new (list tmp))) + (push new byte-compile-variables) + new))))) + ((eq bytedecomp-op 'byte-stack-set2) + (setq bytedecomp-op 'byte-stack-set)) + ((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80)) + ;; The top bit of the operand for byte-discardN is a flag, + ;; saying whether the top-of-stack is preserved. In + ;; lapcode, we represent this by using a different opcode + ;; (with the flag removed from the operand). + (setq bytedecomp-op 'byte-discardN-preserve-tos) + (setq offset (- offset #x80)))) ;; 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. + (push (cons optr (cons bytedecomp-op (or offset 0))) + lap) + (setq bytedecomp-ptr (1+ bytedecomp-ptr))) (let ((rest lap)) (while rest (cond ((numberp (car rest))) ((setq tmp (assq (car (car rest)) tags)) - ;; this addr is jumped to + ;; 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) ]* ) + ;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) (mapcar (function (lambda (elt) (if (numberp elt) elt @@ -1458,7 +1435,7 @@ 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)) + byte-current-buffer byte-stack-ref)) (defconst byte-compile-side-effect-free-ops (nconc @@ -1500,7 +1477,7 @@ ;; The variable `byte-boolean-vars' is now primitive and updated ;; automatically by DEFVAR_BOOL. -(defun byte-optimize-lapcode (lap &optional for-effect) +(defun byte-optimize-lapcode (lap &optional _for-effect) "Simple peephole optimizer. LAP is both modified and returned. If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (let (lap0 @@ -1575,20 +1552,25 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup ;; The latter two can enable other optimizations. ;; + ;; For lexical variables, we could do the same + ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 + ;; but this is a very minor gain, since dup is stack-ref-0, + ;; i.e. it's only better if X>5, and even then it comes + ;; at the cost of an extra stack slot. Let's not bother. ((and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) + (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) - (byte-compile-const-symbol-p - (car (cdr lap0)))) - (cdr lap0) - (byte-compile-get-constant t))) + (if (memq (car lap0) '(byte-constant byte-dup)) + (progn + (setq tmp (if (or (not tmp) + (macroexp--const-symbol-p + (car (cdr lap0)))) + (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)) @@ -1606,14 +1588,17 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ;; dup varset-X discard --> varset-X ;; dup varbind-X discard --> varbind-X + ;; dup stack-set-X discard --> stack-set-X-1 ;; (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))) + (memq (car lap1) '(byte-varset byte-varbind + byte-stack-set))) (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) (setq keep-going t rest (cdr rest)) + (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) (setq lap (delq lap0 (delq lap2 lap)))) ;; ;; not goto-X-if-nil --> goto-X-if-non-nil @@ -1622,8 +1607,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; 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)))) + (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) (byte-compile-log-lap " not %s\t-->\t%s" lap1 (cons @@ -1642,8 +1626,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ;; 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 + ((and (memq (car lap0) + '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX (eq 'byte-goto (car lap1)) ; gotoY (eq (cdr lap0) lap2)) ; TAG X (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) @@ -1658,40 +1642,51 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; 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)))) + (memq (car lap1) byte-conditional-ops) + ;; If the `byte-constant's cdr is not a cons cell, it has + ;; to be an index into the constant pool); even though + ;; it'll be a constant, that constant is not known yet + ;; (it's typically a free variable of a closure, so will + ;; only be known when the closure will be built at + ;; run-time). + (consp (cdr lap0))) + (cond ((if (memq (car lap1) '(byte-goto-if-nil + 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)))) + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 + (cons 'byte-goto (cdr lap1))) + (when (memq (car lap1) byte-goto-always-pop-ops) + (setq lap (delq lap0 lap))) (setcar lap1 'byte-goto))) - (setq keep-going t)) + (setq keep-going t)) ;; ;; varref-X varref-X --> varref-X dup ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup + ;; stackref-X [dup ...] stackref-X+N --> stackref-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)) + ((and (memq (car lap0) '(byte-varref byte-stack-ref)) (progn (setq tmp (cdr rest)) + (setq tmp2 0) (while (eq (car (car tmp)) 'byte-dup) - (setq tmp (cdr tmp))) + (setq tmp2 (1+ tmp2)) + (setq tmp (cdr tmp))) t) - (eq (cdr lap0) (cdr (car tmp))) - (eq 'byte-varref (car (car tmp)))) + (eq (if (eq 'byte-stack-ref (car lap0)) + (+ tmp2 1 (cdr lap0)) + (cdr lap0)) + (cdr (car tmp))) + (eq (car lap0) (car (car tmp)))) (if (memq byte-optimize-log '(t byte)) (let ((str "")) (setq tmp2 (cdr rest)) @@ -1851,18 +1846,21 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (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))) + (cond ((when (consp (cdr lap0)) + (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 + (setq rest (cons nil rest)) + (setq keep-going t)) + ((or (consp (cdr lap0)) + (eq (car tmp2) 'byte-discard)) ;; Jump one step further (byte-compile-log-lap " %s goto [%s]\t-->\t<deleted> goto <skip>" @@ -1871,13 +1869,18 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setcdr tmp (cons (byte-compile-make-tag) (cdr tmp)))) (setcdr lap1 (car (cdr tmp))) - (setq lap (delq lap0 lap)))) - (setq keep-going t)) + (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). + ;; + ;; Here again, we could do it for stack-ref/stack-set, but + ;; that's replacing a stack-ref-Y with a stack-ref-0, which + ;; is a very minor improvement (if any), at the cost of + ;; more stack use and more byte-code. Let's not do it. ;; ((and (eq (car lap1) 'byte-varset) (eq (car lap2) 'byte-goto) @@ -1950,16 +1953,16 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; 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. + ;; need to do more than once. (setq byte-compile-constants nil byte-compile-variables nil) (setq rest lap) + (byte-compile-log-lap " ---- final pass") (while rest (setq lap0 (car rest) lap1 (nth 1 rest)) (if (memq (car lap0) byte-constref-ops) - (if (or (eq (car lap0) 'byte-constant) - (eq (car lap0) 'byte-constant2)) + (if (memq (car lap0) '(byte-constant byte-constant2)) (unless (memq (cdr lap0) byte-compile-constants) (setq byte-compile-constants (cons (cdr lap0) byte-compile-constants))) @@ -2003,10 +2006,86 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (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)))) - ) + + ;; + ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos + ;; stack-set-M [discard/discardN ...] --> discardN + ;; + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (progn + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (setq tmp (cdr rest)) + (setq tmp2 (1- (cdr lap0))) + (setq tmp3 0) + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (setq tmp3 + (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) + 1 + (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (>= tmp3 tmp2))) + ;; Do the optimization. + (setq lap (delq lap0 lap)) + (setcar lap1 + (if (= tmp2 tmp3) + ;; The value stored is the new TOS, so pop one more + ;; value (to get rid of the old value) using the + ;; TOS-preserving discard operator. + 'byte-discardN-preserve-tos + ;; Otherwise, the value stored is lost, so just use a + ;; normal discard. + 'byte-discardN)) + (setcdr lap1 (1+ tmp3)) + (setcdr (cdr rest) tmp) + (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" + lap0 lap1)) + + ;; + ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> + ;; discardN-(X+Y) + ;; + ((and (memq (car lap0) + '(byte-discard byte-discardN + byte-discardN-preserve-tos)) + (memq (car lap1) '(byte-discard byte-discardN))) + (setq lap (delq lap0 lap)) + (byte-compile-log-lap + " %s %s\t-->\t(discardN %s)" + lap0 lap1 + (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcar lap1 'byte-discardN)) + + ;; + ;; discardN-preserve-tos-X discardN-preserve-tos-Y --> + ;; discardN-preserve-tos-(X+Y) + ;; + ((and (eq (car lap0) 'byte-discardN-preserve-tos) + (eq (car lap1) 'byte-discardN-preserve-tos)) + (setq lap (delq lap0 lap)) + (setcdr lap1 (+ (cdr lap0) (cdr lap1))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) + + ;; + ;; discardN-preserve-tos return --> return + ;; dup return --> return + ;; stack-set-N return --> return ; where N is TOS-1 + ;; + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) 1)))) + ;; The byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it. + (setq lap (delq lap0 lap)) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + ) (setq rest (cdr rest))) (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) lap) @@ -2035,5 +2114,4 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." byte-optimize-lapcode)))) nil) -;; arch-tag: 0f14076b-737e-4bef-aae6-908826ec1ff1 ;;; byte-opt.el ends here diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 603b7709f4c..7322c0fbe6f 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -1,12 +1,12 @@ -;;; byte-run.el --- byte-compiler support for inlining +;;; byte-run.el --- byte-compiler support for inlining -*- lexical-binding: t -*- -;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2013 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -30,42 +30,194 @@ ;;; Code: -;; We define macro-declaration-function here because it is needed to -;; handle declarations in macro definitions and this is the first file -;; loaded by loadup.el that uses declarations in macros. +;; `macro-declaration-function' are both obsolete (as marked at the end of this +;; file) but used in many .elc files. + +(defvar macro-declaration-function #'macro-declaration-function + "Function to process declarations in a macro definition. +The function will be called with two args MACRO and DECL. +MACRO is the name of the macro being defined. +DECL is a list `(declare ...)' containing the declarations. +The value the function returns is not used.") -(defun macro-declaration-function (macro decl) - "Process a declaration found in a macro definition. +(defalias 'macro-declaration-function + #'(lambda (macro decl) + "Process a declaration found in a macro definition. This is set as the value of the variable `macro-declaration-function'. MACRO is the name of the macro being defined. DECL is a list `(declare ...)' containing the declarations. The return value of this function is not used." - ;; We can't use `dolist' or `cadr' yet for bootstrapping reasons. - (let (d) - ;; Ignore the first element of `decl' (it's always `declare'). - (while (setq decl (cdr decl)) - (setq d (car decl)) - (if (and (consp d) - (listp (cdr d)) - (null (cdr (cdr d)))) - (cond ((eq (car d) 'indent) - (put macro 'lisp-indent-function (car (cdr d)))) - ((eq (car d) 'debug) - (put macro 'edebug-form-spec (car (cdr d)))) - ((eq (car d) 'doc-string) - (put macro 'doc-string-elt (car (cdr d)))) - (t - (message "Unknown declaration %s" d))) - (message "Invalid declaration %s" d))))) - - -(setq macro-declaration-function 'macro-declaration-function) + ;; We can't use `dolist' or `cadr' yet for bootstrapping reasons. + (let (d) + ;; Ignore the first element of `decl' (it's always `declare'). + (while (setq decl (cdr decl)) + (setq d (car decl)) + (if (and (consp d) + (listp (cdr d)) + (null (cdr (cdr d)))) + (cond ((eq (car d) 'indent) + (put macro 'lisp-indent-function (car (cdr d)))) + ((eq (car d) 'debug) + (put macro 'edebug-form-spec (car (cdr d)))) + ((eq (car d) 'doc-string) + (put macro 'doc-string-elt (car (cdr d)))) + (t + (message "Unknown declaration %s" d))) + (message "Invalid declaration %s" d)))))) + +;; We define macro-declaration-alist here because it is needed to +;; handle declarations in macro definitions and this is the first file +;; loaded by loadup.el that uses declarations in macros. +(defvar defun-declarations-alist + (list + ;; We can only use backquotes inside the lambdas and not for those + ;; properties that are used by functions loaded before backquote.el. + (list 'advertised-calling-convention + #'(lambda (f _args arglist when) + (list 'set-advertised-calling-convention + (list 'quote f) (list 'quote arglist) (list 'quote when)))) + (list 'obsolete + #'(lambda (f _args new-name when) + `(make-obsolete ',f ',new-name ,when))) + (list 'compiler-macro + #'(lambda (f _args compiler-function) + (if (not (symbolp compiler-function)) + (error "Only symbols are supported in `compiler-macro'") + `(put ',f 'compiler-macro #',compiler-function)))) + (list 'doc-string + #'(lambda (f _args pos) + (list 'put (list 'quote f) ''doc-string-elt (list 'quote pos)))) + (list 'indent + #'(lambda (f _args val) + (list 'put (list 'quote f) + ''lisp-indent-function (list 'quote val))))) + "List associating function properties to their macro expansion. +Each element of the list takes the form (PROP FUN) where FUN is +a function. For each (PROP . VALUES) in a function's declaration, +the FUN corresponding to PROP is called with the function name, +the function's arglist, and the VALUES and should return the code to use +to set this property.") + +(defvar macro-declarations-alist + (cons + (list 'debug + #'(lambda (name _args spec) + (list 'progn :autoload-end + (list 'put (list 'quote name) + ''edebug-form-spec (list 'quote spec))))) + defun-declarations-alist) + "List associating properties of macros to their macro expansion. +Each element of the list takes the form (PROP FUN) where FUN is +a function. For each (PROP . VALUES) in a macro's declaration, +the FUN corresponding to PROP is called with the function name +and the VALUES and should return the code to use to set this property.") + +(put 'defmacro 'doc-string-elt 3) +(defalias 'defmacro + (cons + 'macro + #'(lambda (name arglist &optional docstring &rest body) + "Define NAME as a macro. +When the macro is called, as in (NAME ARGS...), +the function (lambda ARGLIST BODY...) is applied to +the list ARGS... as it appears in the expression, +and the result should be a form to be evaluated instead of the original. +DECL is a declaration, optional, of the form (declare DECLS...) where +DECLS is a list of elements of the form (PROP . VALUES). These are +interpreted according to `macro-declarations-alist'. +The return value is undefined. + +\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" + ;; We can't just have `decl' as an &optional argument, because we need + ;; to distinguish + ;; (defmacro foo (arg) (bar) nil) + ;; from + ;; (defmacro foo (arg) (bar)). + (let ((decls (cond + ((eq (car-safe docstring) 'declare) + (prog1 (cdr docstring) (setq docstring nil))) + ((and (stringp docstring) + (eq (car-safe (car body)) 'declare)) + (prog1 (cdr (car body)) (setq body (cdr body))))))) + (if docstring (setq body (cons docstring body)) + (if (null body) (setq body '(nil)))) + ;; Can't use backquote because it's not defined yet! + (let* ((fun (list 'function (cons 'lambda (cons arglist body)))) + (def (list 'defalias + (list 'quote name) + (list 'cons ''macro fun))) + (declarations + (mapcar + #'(lambda (x) + (let ((f (cdr (assq (car x) macro-declarations-alist)))) + (if f (apply (car f) name arglist (cdr x)) + (message "Warning: Unknown macro property %S in %S" + (car x) name)))) + decls))) + (if declarations + (cons 'prog1 (cons def declarations)) + def)))))) + +;; Now that we defined defmacro we can use it! +(defmacro defun (name arglist &optional docstring &rest body) + "Define NAME as a function. +The definition is (lambda ARGLIST [DOCSTRING] BODY...). +See also the function `interactive'. +DECL is a declaration, optional, of the form (declare DECLS...) where +DECLS is a list of elements of the form (PROP . VALUES). These are +interpreted according to `defun-declarations-alist'. +The return value is undefined. + +\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" + ;; We can't just have `decl' as an &optional argument, because we need + ;; to distinguish + ;; (defun foo (arg) (toto) nil) + ;; from + ;; (defun foo (arg) (toto)). + (declare (doc-string 3)) + (let ((decls (cond + ((eq (car-safe docstring) 'declare) + (prog1 (cdr docstring) (setq docstring nil))) + ((and (stringp docstring) + (eq (car-safe (car body)) 'declare)) + (prog1 (cdr (car body)) (setq body (cdr body))))))) + (if docstring (setq body (cons docstring body)) + (if (null body) (setq body '(nil)))) + (let ((declarations + (mapcar + #'(lambda (x) + (let ((f (cdr (assq (car x) defun-declarations-alist)))) + (cond + (f (apply (car f) name arglist (cdr x))) + ;; Yuck!! + ((and (featurep 'cl) + (memq (car x) ;C.f. cl-do-proclaim. + '(special inline notinline optimize warn))) + (push (list 'declare x) + (if (stringp docstring) + (if (eq (car-safe (cadr body)) 'interactive) + (cddr body) + (cdr body)) + (if (eq (car-safe (car body)) 'interactive) + (cdr body) + body))) + nil) + (t (message "Warning: Unknown defun property `%S' in %S" + (car x) name))))) + decls)) + (def (list 'defalias + (list 'quote name) + (list 'function + (cons 'lambda + (cons arglist body)))))) + (if declarations + (cons 'prog1 (cons def declarations)) + def)))) ;; Redefined in byte-optimize.el. ;; This is not documented--it's not clear that we should promote it. (fset 'inline 'progn) -(put 'inline 'lisp-indent-function 0) ;;; Interface to inline functions. @@ -73,7 +225,7 @@ The return value of this function is not used." ;; "Cause the named functions to be open-coded when called from compiled code. ;; They will only be compiled open-coded when byte-compile-optimize is true." ;; (cons 'eval-and-compile -;; (mapcar '(lambda (x) +;; (mapcar (lambda (x) ;; (or (memq (get x 'byte-optimizer) ;; '(nil byte-compile-inline-expand)) ;; (error @@ -86,7 +238,7 @@ The return value of this function is not used." ;; (defmacro proclaim-notinline (&rest fns) ;; "Cause the named functions to no longer be open-coded." ;; (cons 'eval-and-compile -;; (mapcar '(lambda (x) +;; (mapcar (lambda (x) ;; (if (eq (get x 'byte-optimizer) 'byte-compile-inline-expand) ;; (put x 'byte-optimizer nil)) ;; (list 'if (list 'eq (list 'get (list 'quote x) ''byte-optimizer) @@ -94,10 +246,10 @@ The return value of this function is not used." ;; (list 'put x ''byte-optimizer nil))) ;; fns))) -;; This has a special byte-hunk-handler in bytecomp.el. (defmacro defsubst (name arglist &rest body) - "Define an inline function. The syntax is just like that of `defun'." - (declare (debug defun)) + "Define an inline function. The syntax is just like that of `defun'. +\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" + (declare (debug defun) (doc-string 3)) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) @@ -108,7 +260,7 @@ The return value of this function is not used." (defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key)) -(defun set-advertised-calling-convention (function signature when) +(defun set-advertised-calling-convention (function signature _when) "Set the advertised SIGNATURE of FUNCTION. This will allow the byte-compiler to warn the programmer when she uses an obsolete calling convention. WHEN specifies since when the calling @@ -117,23 +269,23 @@ convention was modified." advertised-signature-table)) (defun make-obsolete (obsolete-name current-name &optional when) - "Make the byte-compiler warn that OBSOLETE-NAME is obsolete. + "Make the byte-compiler warn that function OBSOLETE-NAME is obsolete. +OBSOLETE-NAME should be a function name or macro name (a symbol). + The warning will say that CURRENT-NAME should be used instead. If CURRENT-NAME is a string, that is the `use instead' message \(it should end with a period, and not start with a capital). -If provided, WHEN should be a string indicating when the function +WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number." + (declare (advertised-calling-convention + ;; New code should always provide the `when' argument. + (obsolete-name current-name when) "23.1")) (interactive "aMake function obsolete: \nxObsoletion replacement: ") - (let ((handler (get obsolete-name 'byte-compile))) - (if (eq 'byte-compile-obsolete handler) - (setq handler (nth 1 (get obsolete-name 'byte-obsolete-info))) - (put obsolete-name 'byte-compile 'byte-compile-obsolete)) - (put obsolete-name 'byte-obsolete-info - (list (purecopy current-name) handler (purecopy when)))) + (put obsolete-name 'byte-obsolete-info + ;; The second entry used to hold the `byte-compile' handler, but + ;; is not used any more nowadays. + (purecopy (list current-name nil when))) obsolete-name) -(set-advertised-calling-convention - ;; New code should always provide the `when' argument. - 'make-obsolete '(obsolete-name current-name when) "23.1") (defmacro define-obsolete-function-alias (obsolete-name current-name &optional when docstring) @@ -147,36 +299,29 @@ is equivalent to the following two lines of code: \(make-obsolete 'old-fun 'new-fun \"22.1\") See the docstrings of `defalias' and `make-obsolete' for more details." - (declare (doc-string 4)) + (declare (doc-string 4) + (advertised-calling-convention + ;; New code should always provide the `when' argument. + (obsolete-name current-name when &optional docstring) "23.1")) `(progn (defalias ,obsolete-name ,current-name ,docstring) (make-obsolete ,obsolete-name ,current-name ,when))) -(set-advertised-calling-convention - ;; New code should always provide the `when' argument. - 'define-obsolete-function-alias - '(obsolete-name current-name when &optional docstring) "23.1") -(defun make-obsolete-variable (obsolete-name current-name &optional when) +(defun make-obsolete-variable (obsolete-name current-name &optional when access-type) "Make the byte-compiler warn that OBSOLETE-NAME is obsolete. The warning will say that CURRENT-NAME should be used instead. If CURRENT-NAME is a string, that is the `use instead' message. -If provided, WHEN should be a string indicating when the variable -was first made obsolete, for example a date or a release number." - (interactive - (list - (let ((str (completing-read "Make variable obsolete: " obarray 'boundp t))) - (if (equal str "") (error "")) - (intern str)) - (car (read-from-string (read-string "Obsoletion replacement: "))))) +WHEN should be a string indicating when the variable +was first made obsolete, for example a date or a release number. +ACCESS-TYPE if non-nil should specify the kind of access that will trigger + obsolescence warnings; it can be either `get' or `set'." + (declare (advertised-calling-convention + ;; New code should always provide the `when' argument. + (obsolete-name current-name when &optional access-type) "23.1")) (put obsolete-name 'byte-obsolete-variable - (cons - (if (stringp current-name) - (purecopy current-name) - current-name) (purecopy when))) + (purecopy (list current-name access-type when))) obsolete-name) -(set-advertised-calling-convention - ;; New code should always provide the `when' argument. - 'make-obsolete-variable '(obsolete-name current-name when) "23.1") + (defmacro define-obsolete-variable-alias (obsolete-name current-name &optional when docstring) @@ -185,7 +330,7 @@ This uses `defvaralias' and `make-obsolete-variable' (which see). See the Info node `(elisp)Variable Aliases' for more details. If CURRENT-NAME is a defcustom (more generally, any variable -where OBSOLETE-NAME may be set, e.g. in a .emacs file, before the +where OBSOLETE-NAME may be set, e.g. in an init file, before the alias is defined), then the define-obsolete-variable-alias statement should be evaluated before the defcustom, if user customizations are to be respected. The simplest way to achieve @@ -199,7 +344,10 @@ For the benefit of `custom-set-variables', if OBSOLETE-NAME has any of the following properties, they are copied to CURRENT-NAME, if it does not already have them: 'saved-value, 'saved-variable-comment." - (declare (doc-string 4)) + (declare (doc-string 4) + (advertised-calling-convention + ;; New code should always provide the `when' argument. + (obsolete-name current-name when &optional docstring) "23.1")) `(progn (defvaralias ,obsolete-name ,current-name ,docstring) ;; See Bug#4706. @@ -208,10 +356,6 @@ CURRENT-NAME, if it does not already have them: (null (get ,current-name prop)) (put ,current-name prop (get ,obsolete-name prop)))) (make-obsolete-variable ,obsolete-name ,current-name ,when))) -(set-advertised-calling-convention - ;; New code should always provide the `when' argument. - 'define-obsolete-variable-alias - '(obsolete-name current-name when &optional docstring) "23.1") ;; FIXME This is only defined in this file because the variable- and ;; function- versions are too. Unlike those two, this one is not used @@ -292,5 +436,9 @@ In interpreted code, this is entirely equivalent to `progn'." ;; (file-format emacs19))" ;; nil) -;; arch-tag: 76f8328a-1f66-4df2-9b6d-5c3666dc05e9 +(make-obsolete-variable 'macro-declaration-function + 'macro-declarations-alist "24.3") +(make-obsolete 'macro-declaration-function + 'macro-declarations-alist "24.3") + ;;; byte-run.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a841a4bb198..ce3a3324e18 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1,12 +1,13 @@ -;;; bytecomp.el --- compilation of Lisp code into byte code +;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*- -;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1998, 2000, 2001, 2002, -;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2013 Free Software +;; Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Maintainer: FSF ;; Keywords: lisp +;; Package: emacs ;; This file is part of GNU Emacs. @@ -35,6 +36,7 @@ ;; ======================================================================== ;; Entry points: ;; byte-recompile-directory, byte-compile-file, +;; byte-recompile-file, ;; batch-byte-compile, batch-byte-recompile-directory, ;; byte-compile, compile-defun, ;; display-call-tree @@ -116,12 +118,16 @@ ;; Some versions of `file' can be customized to recognize that. (require 'backquote) -(eval-when-compile (require 'cl)) +(require 'macroexp) +(require 'cconv) +(eval-when-compile (require 'cl-lib)) (or (fboundp 'defsubst) ;; This really ought to be loaded already! (load "byte-run")) +;; The feature of compiling in a specific target Emacs version +;; has been turned off because compile time options are a bad idea. (defgroup bytecomp nil "Emacs Lisp byte-compiler." :group 'lisp) @@ -172,9 +178,9 @@ adds `c' to it; otherwise adds `.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. +;; This is the entry point to the lapcode optimizer pass1. (autoload 'byte-optimize-form "byte-opt") -;; This is the entrypoint to the lapcode optimizer pass2. +;; This is the entry point to the lapcode optimizer pass2. (autoload 'byte-optimize-lapcode "byte-opt") (autoload 'byte-compile-unfold-lambda "byte-opt") @@ -225,6 +231,7 @@ the functions you loaded will not be able to run.") (defvar byte-compile-disable-print-circle nil "If non-nil, disable `print-circle' on printing a byte-compiled code.") +(make-obsolete-variable 'byte-compile-disable-print-circle nil "24.1") ;;;###autoload(put 'byte-compile-disable-print-circle 'safe-local-variable 'booleanp) (defcustom byte-compile-dynamic-docstrings t @@ -245,10 +252,14 @@ This option is enabled by default because it reduces Emacs memory usage." :type 'boolean) ;;;###autoload(put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp) +(defconst byte-compile-log-buffer "*Compile-Log*" + "Name of the byte-compiler's log buffer.") + (defcustom byte-optimize-log nil - "If true, the byte-compiler will log its optimizations into *Compile-Log*. + "If non-nil, the byte-compiler will log its optimizations. If this is 'source, then only source-level optimizations will be logged. -If it is 'byte, then only byte-level optimizations will be logged." +If it is 'byte, then only byte-level optimizations will be logged. +The information is logged to `byte-compile-log-buffer'." :group 'bytecomp :type '(choice (const :tag "none" nil) (const :tag "all" t) @@ -263,7 +274,7 @@ If it is 'byte, then only byte-level optimizations will be logged." (defconst byte-compile-warning-types '(redefine callargs free-vars unresolved obsolete noruntime cl-functions interactive-only - make-local mapcar constants suspicious) + make-local mapcar constants suspicious lexical) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for all). @@ -348,10 +359,12 @@ else the global value will be modified." "List of commands that are not meant to be called from Lisp.") (defvar byte-compile-not-obsolete-vars nil - "If non-nil, a list of variables that shouldn't be reported as obsolete.") + "List of variables that shouldn't be reported as obsolete.") +(defvar byte-compile-global-not-obsolete-vars nil + "Global list of variables that shouldn't be reported as obsolete.") (defvar byte-compile-not-obsolete-funcs nil - "If non-nil, a list of functions that shouldn't be reported as obsolete.") + "List of functions that shouldn't be reported as obsolete.") (defcustom byte-compile-generate-call-tree nil "Non-nil means collect call-graph information when compiling. @@ -395,7 +408,7 @@ specify different fields to sort on." (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. + "List of dynamic variables bound in the context of the current form. This list lives partly on the stack.") (defvar byte-compile-const-variables nil "List of variables declared as constants during compilation of this file.") @@ -408,10 +421,13 @@ This list lives partly on the stack.") '( ;; (byte-compiler-options . (lambda (&rest forms) ;; (apply 'byte-compiler-options-handler forms))) + (declare-function . byte-compile-macroexpand-declare-function) (eval-when-compile . (lambda (&rest body) - (list 'quote - (byte-compile-eval (byte-compile-top-level - (cons 'progn body)))))) + (list + 'quote + (byte-compile-eval + (byte-compile-top-level + (byte-compile-preprocess (cons 'progn body))))))) (eval-and-compile . (lambda (&rest body) (byte-compile-eval-before-compile (cons 'progn body)) (cons 'progn body)))) @@ -444,6 +460,10 @@ defined with incorrect args.") Used for warnings about calling a function that is defined during compilation but won't necessarily be defined when the compiled file is loaded.") +;; Variables for lexical binding +(defvar byte-compile--lexical-environment nil + "The current lexical environment.") + (defvar byte-compile-tag-number 0) (defvar byte-compile-output nil "Alist describing contents to put in byte code string. @@ -489,11 +509,10 @@ Each element is (INDEX . VALUE)") (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 0 1 byte-stack-ref "for stack reference") (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") @@ -563,7 +582,7 @@ Each element is (INDEX . VALUE)") (byte-defop 114 0 byte-save-current-buffer "To make a binding to record the current buffer") (byte-defop 115 0 byte-set-mark-OBSOLETE) -(byte-defop 116 1 byte-interactive-p) +(byte-defop 116 1 byte-interactive-p-OBSOLETE) ;; These ops are new to v19 (byte-defop 117 0 byte-forward-char) @@ -599,7 +618,7 @@ otherwise pop it") (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 +(byte-defop 139 0 byte-save-window-excursion-OBSOLETE "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") @@ -612,17 +631,8 @@ otherwise pop it") ;; 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) +(byte-defop 144 0 byte-temp-output-buffer-setup-OBSOLETE) +(byte-defop 145 -1 byte-temp-output-buffer-show-OBSOLETE) ;; these ops are new to v19 @@ -659,7 +669,21 @@ otherwise pop it") (byte-defop 176 nil byte-concatN) (byte-defop 177 nil byte-insertN) -;; unused: 178-191 +(byte-defop 178 -1 byte-stack-set) ; Stack offset in following one byte. +(byte-defop 179 -1 byte-stack-set2) ; Stack offset in following two bytes. + +;; If (following one byte & 0x80) == 0 +;; discard (following one byte & 0x7F) stack entries +;; else +;; discard (following one byte & 0x7F) stack entries _underneath_ TOS +;; (that is, if the operand = 0x83, ... X Y Z T => ... T) +(byte-defop 182 nil byte-discardN) +;; `byte-discardN-preserve-tos' is a pseudo-op that gets turned into +;; `byte-discardN' with the high bit in the operand set (by +;; `byte-compile-lapcode'). +(defconst byte-discardN-preserve-tos byte-discardN) + +;; unused: 182-191 (byte-defop 192 1 byte-constant "for reference to a constant") ;; codes 193-255 are consumed by byte-constant. @@ -706,71 +730,114 @@ otherwise pop it") ;; front of the constants-vector than the constant-referencing instructions. ;; Also, this lets us notice references to free variables. +(defmacro byte-compile-push-bytecodes (&rest args) + "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed. +ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names. +BYTES and PC are updated after evaluating all the arguments." + (let ((byte-exprs (butlast args 2)) + (bytes-var (car (last args 2))) + (pc-var (car (last args)))) + `(setq ,bytes-var ,(if (null (cdr byte-exprs)) + `(progn (cl-assert (<= 0 ,(car byte-exprs))) + (cons ,@byte-exprs ,bytes-var)) + `(nconc (list ,@(reverse byte-exprs)) ,bytes-var)) + ,pc-var (+ ,(length byte-exprs) ,pc-var)))) + +(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc) + "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC. +CONST2 may be evaluated multiple times." + `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8) + ,bytes ,pc)) + (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 + opcode ; numeric value of OP (bytes '()) ; Put the output bytes here - (patchlist nil)) ; List of tags and goto's to patch - (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))) + (patchlist nil)) ; List of gotos to patch + (dolist (lap-entry lap) + (setq op (car lap-entry) + off (cdr lap-entry)) + (cond + ((not (symbolp op)) + (error "Non-symbolic opcode `%s'" op)) + ((eq op 'TAG) + (setcar off pc)) + (t + (setq opcode + (if (eq op 'byte-discardN-preserve-tos) + ;; byte-discardN-preserve-tos is a pseudo op, which + ;; is actually the same as byte-discardN + ;; with a modified argument. + byte-discardN + (symbol-value op))) + (cond ((memq op byte-goto-ops) + ;; goto + (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) + (push bytes patchlist)) + ((or (and (consp off) + ;; Variable or constant reference + (progn + (setq off (cdr off)) + (eq op 'byte-constant))) + (and (eq op 'byte-constant) + (integerp off))) + ;; constant ref + (if (< off byte-constant-limit) + (byte-compile-push-bytecodes (+ byte-constant off) + bytes pc) + (byte-compile-push-bytecode-const2 byte-constant2 off + bytes pc))) + ((and (= opcode byte-stack-set) + (> off 255)) + ;; Use the two-byte version of byte-stack-set if the + ;; offset is too large for the normal version. + (byte-compile-push-bytecode-const2 byte-stack-set2 off + bytes pc)) + ((and (>= opcode byte-listN) + (< opcode byte-discardN)) + ;; These insns all put their operand into one extra byte. + (byte-compile-push-bytecodes opcode off bytes pc)) + ((= opcode byte-discardN) + ;; byte-discardN is weird in that it encodes a flag in the + ;; top bit of its one-byte argument. If the argument is + ;; too large to fit in 7 bits, the opcode can be repeated. + (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0))) + (while (> off #x7f) + (byte-compile-push-bytecodes opcode (logior #x7f flag) + bytes pc) + (setq off (- off #x7f))) + (byte-compile-push-bytecodes opcode (logior off flag) + bytes pc))) + ((null off) + ;; opcode that doesn't use OFF + (byte-compile-push-bytecodes opcode bytes pc)) + ((and (eq opcode byte-stack-ref) (eq off 0)) + ;; (stack-ref 0) is really just another name for `dup'. + (debug) ;FIXME: When would this happen? + (byte-compile-push-bytecodes byte-dup bytes pc)) + ;; The following three cases are for the special + ;; insns that encode their operand into 0, 1, or 2 + ;; extra bytes depending on its magnitude. + ((< off 6) + (byte-compile-push-bytecodes (+ opcode off) bytes pc)) + ((< off 256) + (byte-compile-push-bytecodes (+ opcode 6) off bytes pc)) + (t + (byte-compile-push-bytecode-const2 (+ opcode 7) off + bytes pc)))))) ;;(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)) - ;; FIXME: Replace this by some workaround. - (if (> (car bytes) 255) (error "Bytecode overflow")))) - (setq patchlist (cdr patchlist)))) + ;; Patch tag PCs into absolute jumps. + (dolist (bytes-tail patchlist) + (setq pc (caar bytes-tail)) ; Pick PC from goto's tag. + (setcar (cdr bytes-tail) (logand pc 255)) + (setcar bytes-tail (lsh pc -8)) + ;; FIXME: Replace this by some workaround. + (if (> (car bytes-tail) 255) (error "Bytecode overflow"))) + (apply 'unibyte-string (nreverse bytes)))) @@ -779,14 +846,14 @@ otherwise pop it") (defun byte-compile-cl-file-p (file) "Return non-nil if FILE is one of the CL files." (and (stringp file) - (string-match "^cl\\>" (file-name-nondirectory file)))) + (string-match "^cl\\.el" (file-name-nondirectory file)))) (defun byte-compile-eval (form) "Eval FORM and mark the functions defined therein. Each function's symbol gets added to `byte-compile-noruntime-functions'." (let ((hist-orig load-history) (hist-nil-orig current-load-list)) - (prog1 (eval form) + (prog1 (eval form lexical-binding) (when (byte-compile-warning-enabled-p 'noruntime) (let ((hist-new load-history) (hist-nil-new current-load-list)) @@ -808,13 +875,11 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (byte-compile-cl-file-p (car xs)))) (dolist (s xs) (cond - ((symbolp s) - (unless (memq s old-autoloads) - (push s byte-compile-noruntime-functions))) ((and (consp s) (eq t (car s))) (push (cdr s) old-autoloads)) - ((and (consp s) (eq 'autoload (car s))) - (push (cdr s) byte-compile-noruntime-functions))))))) + ((and (consp s) (memq (car s) '(autoload defun))) + (unless (memq (cdr s) old-autoloads) + (push (cdr s) byte-compile-noruntime-functions)))))))) ;; Go through current-load-list for the locally defined funs. (let (old-autoloads) (while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig))) @@ -838,7 +903,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defun byte-compile-eval-before-compile (form) "Evaluate FORM for `eval-and-compile'." (let ((hist-nil-orig current-load-list)) - (prog1 (eval form) + (prog1 (eval form lexical-binding) ;; (eval-and-compile (require 'cl) turns off warnings for cl functions. ;; FIXME Why does it do that - just as a hack? ;; There are other ways to do this nowadays. @@ -873,7 +938,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;; Log something that isn't a warning. (defun byte-compile-log-1 (string) - (with-current-buffer "*Compile-Log*" + (with-current-buffer byte-compile-log-buffer (let ((inhibit-read-only t)) (goto-char (point-max)) (byte-compile-warning-prefix nil nil) @@ -929,22 +994,38 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." read-symbol-positions-list (byte-compile-delete-first entry read-symbol-positions-list))) - (or (and allow-previous (not (= last byte-compile-last-position))) + (or (and allow-previous + (not (= last byte-compile-last-position))) (> last byte-compile-last-position))))))) (defvar byte-compile-last-warned-form nil) (defvar byte-compile-last-logged-file nil) +(defvar byte-compile-root-dir nil + "Directory relative to which file names in error messages are written.") + +;; FIXME: We should maybe extend abbreviate-file-name with an optional DIR +;; argument to try and use a relative file-name. +(defun byte-compile-abbreviate-file (file &optional dir) + (let ((f1 (abbreviate-file-name file)) + (f2 (file-relative-name file dir))) + (if (< (length f2) (length f1)) f2 f1))) ;; This is used as warning-prefix for the compiler. ;; It is always called with the warnings buffer current. (defun byte-compile-warning-prefix (level entry) (let* ((inhibit-read-only t) - (dir default-directory) + (dir (or byte-compile-root-dir default-directory)) (file (cond ((stringp byte-compile-current-file) - (format "%s:" (file-relative-name byte-compile-current-file dir))) + (format "%s:" (byte-compile-abbreviate-file + byte-compile-current-file dir))) ((bufferp byte-compile-current-file) (format "Buffer %s:" (buffer-name byte-compile-current-file))) + ;; We might be simply loading a file that + ;; contains explicit calls to byte-compile functions. + ((stringp load-file-name) + (format "%s:" (byte-compile-abbreviate-file + load-file-name dir))) (t ""))) (pos (if (and byte-compile-current-file (integerp byte-compile-read-position)) @@ -975,19 +1056,19 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;; This no-op function is used as the value of warning-series ;; to tell inner calls to displaying-byte-compile-warnings ;; not to bind warning-series. -(defun byte-compile-warning-series (&rest ignore) +(defun byte-compile-warning-series (&rest _ignore) nil) ;; (compile-mode) will cause this to be loaded. (declare-function compilation-forget-errors "compile" ()) -;; Log the start of a file in *Compile-Log*, and mark it as done. +;; Log the start of a file in `byte-compile-log-buffer', and mark it as done. ;; Return the position of the start of the page in the log buffer. ;; But do nothing in batch mode. (defun byte-compile-log-file () (and (not (equal byte-compile-current-file byte-compile-last-logged-file)) (not noninteractive) - (with-current-buffer (get-buffer-create "*Compile-Log*") + (with-current-buffer (get-buffer-create byte-compile-log-buffer) (goto-char (point-max)) (let* ((inhibit-read-only t) (dir (and byte-compile-current-file @@ -1004,13 +1085,15 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (insert "\f\nCompiling " (if (stringp byte-compile-current-file) (concat "file " byte-compile-current-file) - (concat "buffer " (buffer-name byte-compile-current-file))) + (concat "buffer " + (buffer-name byte-compile-current-file))) " at " (current-time-string) "\n") (insert "\f\nCompiling no file at " (current-time-string) "\n")) (when dir (setq default-directory dir) (unless was-same - (insert (format "Entering directory `%s'\n" default-directory)))) + (insert (format "Entering directory `%s'\n" + default-directory)))) (setq byte-compile-last-logged-file byte-compile-current-file byte-compile-last-warned-form nil) ;; Do this after setting default-directory. @@ -1018,14 +1101,14 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (compilation-forget-errors) pt)))) -;; Log a message STRING in *Compile-Log*. +;; Log a message STRING in `byte-compile-log-buffer'. ;; Also log the current function and file if not already done. (defun byte-compile-log-warning (string &optional fill level) (let ((warning-prefix-function 'byte-compile-warning-prefix) (warning-type-format "") (warning-fill-prefix (if fill " ")) (inhibit-read-only t)) - (display-warning 'bytecomp string level "*Compile-Log*"))) + (display-warning 'bytecomp string level byte-compile-log-buffer))) (defun byte-compile-warn (format &rest args) "Issue a byte compiler warning; use (format FORMAT ARGS...) for message." @@ -1038,18 +1121,12 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." "Warn that SYMBOL (a variable or function) is obsolete." (when (byte-compile-warning-enabled-p 'obsolete) (let* ((funcp (get symbol 'byte-obsolete-info)) - (obsolete (or funcp (get symbol 'byte-obsolete-variable))) - (instead (car obsolete)) - (asof (if funcp (nth 2 obsolete) (cdr obsolete)))) + (msg (macroexp--obsolete-warning + symbol + (or funcp (get symbol 'byte-obsolete-variable)) + (if funcp "function" "variable")))) (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) - (byte-compile-warn "`%s' is an obsolete %s%s%s" symbol - (if funcp "function" "variable") - (if asof (concat " (as of Emacs " asof ")") "") - (cond ((stringp instead) - (concat "; " instead)) - (instead - (format "; use `%s' instead." instead)) - (t "."))))))) + (byte-compile-warn "%s" msg))))) (defun byte-compile-report-error (error-info) "Report Lisp error in compilation. ERROR-INFO is the error data." @@ -1057,13 +1134,6 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (byte-compile-log-warning (error-message-string error-info) nil :error)) - -;;; Used by make-obsolete. -(defun byte-compile-obsolete (form) - (byte-compile-set-symbol-position (car form)) - (byte-compile-warn-obsolete (car form)) - (funcall (or (cadr (get (car form) 'byte-obsolete-info)) ; handler - 'byte-compile-normal-call) form)) ;;; sanity-checking arglists @@ -1103,22 +1173,32 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (t 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)) + (cond + ;; New style byte-code arglist. + ((integerp arglist) + (cons (logand arglist 127) ;Mandatory. + (if (zerop (logand arglist 128)) ;No &rest. + (lsh arglist -8)))) ;Nonrest. + ;; Old style byte-code, or interpreted function. + ((listp 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))))) + (setq arglist (cdr arglist))) + (cons args (if restp nil (if opts (+ args opts) args))))) + ;; Unknown arglist. + (t '(0)))) (defun byte-compile-arglist-signatures-congruent-p (old new) @@ -1178,8 +1258,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;; and/or remember its arity if it's unknown. (or (and (or def (fboundp (car form))) ; might be a subr or autoload. (not (memq (car form) byte-compile-noruntime-functions))) - (eq (car form) byte-compile-current-form) ; ## this doesn't work - ; with recursion. + (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)) @@ -1237,58 +1317,68 @@ extra args." (custom-declare-variable . defcustom)))) (cadr name))) ;; Update the current group, if needed. - (if (and byte-compile-current-file ;Only when byte-compiling a whole file. + (if (and byte-compile-current-file ;Only when compiling a whole file. (eq (car form) 'custom-declare-group) (eq (car-safe name) 'quote)) (setq byte-compile-current-group (cadr name)))))) ;; 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))) +(defun byte-compile-arglist-warn (name arglist macrop) + (let* ((old (byte-compile-fdefinition name macrop)) + (initial (and macrop + (cdr (assq name + byte-compile-initial-macro-environment))))) + ;; Assumes an element of b-c-i-macro-env that is a symbol points + ;; to a defined function. (Bug#8646) + (and initial (symbolp initial) + (setq old (byte-compile-fdefinition initial nil))) (if (and old (not (eq old t))) (progn (and (eq 'macro (car-safe old)) (eq 'lambda (car-safe (cdr-safe old))) (setq old (cdr 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)))) + (pcase old + (`(lambda ,args . ,_) args) + (`(closure ,_ ,args . ,_) args) + ((pred byte-code-function-p) (aref old 0)) + (t '(&rest def))))) + (sig2 (byte-compile-arglist-signature arglist))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) - (byte-compile-set-symbol-position (nth 1 form)) + (byte-compile-set-symbol-position name) (byte-compile-warn "%s %s used to take %s %s, now takes %s" - (if (eq (car form) 'defun) "function" "macro") - (nth 1 form) + (if macrop "macro" "function") + name (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)) + (let ((calls (assq name 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))) - (when (or (< min (car sig)) - (and (cdr sig) (> max (cdr sig)))) - (byte-compile-set-symbol-position (nth 1 form)) - (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))))) - ))) + (when calls + (when (and (symbolp name) + (eq (function-get name 'byte-optimizer) + 'byte-compile-inline-expand)) + (byte-compile-warn "defsubst `%s' was used before it was defined" + name)) + (setq sig (byte-compile-arglist-signature arglist) + nums (sort (copy-sequence (cdr calls)) (function <)) + min (car nums) + max (car (nreverse nums))) + (when (or (< min (car sig)) + (and (cdr sig) (> max (cdr sig)))) + (byte-compile-set-symbol-position name) + (byte-compile-warn + "%s being defined to take %s%s, but was previously called with %s" + name + (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))))))) (defvar byte-compile-cl-functions nil "List of functions defined in CL.") @@ -1313,26 +1403,19 @@ extra args." ;; These aren't all aliases of subrs, so not trivial to ;; avoid hardwiring the list. (not (memq func - '(cl-block-wrapper cl-block-throw + '(cl--block-wrapper cl--block-throw multiple-value-call nth-value copy-seq first second rest endp cl-member ;; These are included in generated code ;; that can't be called except at compile time ;; or unless cl is loaded anyway. - cl-defsubst-expand cl-struct-setf-expander + cl--defsubst-expand cl-struct-setf-expander ;; These would sometimes be warned about ;; but such warnings are never useful, ;; so don't warn about them. macroexpand cl-macroexpand-all - cl-compiling-file))) - ;; Avoid warnings for things which are safe because they - ;; have suitable compiler macros, but those aren't - ;; expanded at this stage. There should probably be more - ;; here than caaar and friends. - (not (and (eq (get func 'byte-compile) - 'cl-byte-compile-compiler-macro) - (string-match "\\`c[ad]+r\\'" (symbol-name func))))) - (byte-compile-warn "Function `%s' from cl package called at runtime" + cl--compiling-file)))) + (byte-compile-warn "function `%s' from cl package called at runtime" func))) form) @@ -1385,63 +1468,48 @@ extra args." nil) -(defsubst byte-compile-const-symbol-p (symbol &optional any-value) - "Non-nil if SYMBOL is constant. -If ANY-VALUE is nil, only return non-nil if the value of the symbol is the -symbol itself." - (or (memq symbol '(nil t)) - (keywordp symbol) - (if any-value - (or (memq symbol byte-compile-const-variables) - ;; FIXME: We should provide a less intrusive way to find out - ;; is a variable is "constant". - (and (boundp symbol) - (condition-case nil - (progn (set symbol (symbol-value symbol)) nil) - (setting-constant t))))))) - -(defmacro byte-compile-constp (form) - "Return non-nil if FORM is a constant." - `(cond ((consp ,form) (eq (car ,form) 'quote)) - ((not (symbolp ,form))) - ((byte-compile-const-symbol-p ,form)))) +;; Dynamically bound in byte-compile-from-buffer. +;; NB also used in cl.el and cl-macs.el. +(defvar byte-compile--outbuffer) (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-const-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-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 byte-compile-warnings) - ) - body))) + (declare (debug t)) + `(let (;; + ;; 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--outbuffer nil) + (byte-compile-function-environment nil) + (byte-compile-bound-variables nil) + (byte-compile-const-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-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 byte-compile-warnings) + ) + ,@body)) (defmacro displaying-byte-compile-warnings (&rest body) + (declare (debug t)) `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body)) (warning-series-started (and (markerp warning-series) (eq (marker-buffer warning-series) - (get-buffer "*Compile-Log*"))))) + (get-buffer byte-compile-log-buffer))))) (byte-compile-find-cl-functions) (if (or (eq warning-series 'byte-compile-warning-series) warning-series-started) @@ -1474,41 +1542,33 @@ Files in subdirectories of DIRECTORY are processed also." (interactive "DByte force recompile (directory): ") (byte-recompile-directory directory nil t)) -;; The `bytecomp-' prefix is applied to all local variables with -;; otherwise common names in this and similar functions for the sake -;; of the boundp test in byte-compile-variable-ref. -;; http://lists.gnu.org/archive/html/emacs-devel/2008-01/msg00237.html -;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2008-02/msg00134.html -;; Note that similar considerations apply to command-line-1 in startup.el. ;;;###autoload -(defun byte-recompile-directory (bytecomp-directory &optional bytecomp-arg - bytecomp-force) - "Recompile every `.el' file in BYTECOMP-DIRECTORY that needs recompilation. +(defun byte-recompile-directory (directory &optional arg force) + "Recompile every `.el' file in DIRECTORY that needs recompilation. This happens when a `.elc' file exists but is older than the `.el' file. -Files in subdirectories of BYTECOMP-DIRECTORY are processed also. +Files in subdirectories of DIRECTORY are processed also. If the `.elc' file does not exist, normally this function *does not* compile the corresponding `.el' file. However, if the prefix argument -BYTECOMP-ARG is 0, that means do compile all those files. A nonzero -BYTECOMP-ARG means ask the user, for each such `.el' file, whether to -compile it. A nonzero BYTECOMP-ARG also means ask about each subdirectory +ARG is 0, that means do compile all those files. A nonzero +ARG means ask the user, for each such `.el' file, whether to +compile it. A nonzero ARG also means ask about each subdirectory before scanning it. -If the third argument BYTECOMP-FORCE is non-nil, recompile every `.el' file +If the third argument FORCE is non-nil, recompile every `.el' file that already has a `.elc' file." (interactive "DByte recompile directory: \nP") - (if bytecomp-arg - (setq bytecomp-arg (prefix-numeric-value bytecomp-arg))) + (if arg (setq arg (prefix-numeric-value arg))) (if noninteractive nil (save-some-buffers) (force-mode-line-update)) - (with-current-buffer (get-buffer-create "*Compile-Log*") - (setq default-directory (expand-file-name bytecomp-directory)) + (with-current-buffer (get-buffer-create byte-compile-log-buffer) + (setq default-directory (expand-file-name directory)) ;; compilation-mode copies value of default-directory. (unless (eq major-mode 'compilation-mode) (compilation-mode)) - (let ((bytecomp-directories (list default-directory)) + (let ((directories (list default-directory)) (default-directory default-directory) (skip-count 0) (fail-count 0) @@ -1516,57 +1576,37 @@ that already has a `.elc' file." (dir-count 0) last-dir) (displaying-byte-compile-warnings - (while bytecomp-directories - (setq bytecomp-directory (car bytecomp-directories)) - (message "Checking %s..." bytecomp-directory) - (let ((bytecomp-files (directory-files bytecomp-directory)) - bytecomp-source bytecomp-dest) - (dolist (bytecomp-file bytecomp-files) - (setq bytecomp-source - (expand-file-name bytecomp-file bytecomp-directory)) - (if (and (not (member bytecomp-file '("RCS" "CVS"))) - (not (eq ?\. (aref bytecomp-file 0))) - (file-directory-p bytecomp-source) - (not (file-symlink-p bytecomp-source))) - ;; This file is a subdirectory. Handle them differently. - (when (or (null bytecomp-arg) - (eq 0 bytecomp-arg) - (y-or-n-p (concat "Check " bytecomp-source "? "))) - (setq bytecomp-directories - (nconc bytecomp-directories (list bytecomp-source)))) - ;; It is an ordinary file. Decide whether to compile it. - (if (and (string-match emacs-lisp-file-regexp bytecomp-source) - (file-readable-p bytecomp-source) - (not (auto-save-file-name-p bytecomp-source)) - (setq bytecomp-dest - (byte-compile-dest-file bytecomp-source)) - (if (file-exists-p bytecomp-dest) - ;; File was already compiled. - (or bytecomp-force - (file-newer-than-file-p bytecomp-source - bytecomp-dest)) - ;; No compiled file exists yet. - (and bytecomp-arg - (or (eq 0 bytecomp-arg) - (y-or-n-p (concat "Compile " - bytecomp-source "? ")))))) - (progn (if (and noninteractive (not byte-compile-verbose)) - (message "Compiling %s..." bytecomp-source)) - (let ((bytecomp-res (byte-compile-file - bytecomp-source))) - (cond ((eq bytecomp-res 'no-byte-compile) - (setq skip-count (1+ skip-count))) - ((eq bytecomp-res t) - (setq file-count (1+ file-count))) - ((eq bytecomp-res nil) - (setq fail-count (1+ fail-count))))) - (or noninteractive - (message "Checking %s..." bytecomp-directory)) - (if (not (eq last-dir bytecomp-directory)) - (setq last-dir bytecomp-directory - dir-count (1+ dir-count))) - ))))) - (setq bytecomp-directories (cdr bytecomp-directories)))) + (while directories + (setq directory (car directories)) + (message "Checking %s..." directory) + (dolist (file (directory-files directory)) + (let ((source (expand-file-name file directory))) + (if (and (not (member file '("RCS" "CVS"))) + (not (eq ?\. (aref file 0))) + (file-directory-p source) + (not (file-symlink-p source))) + ;; This file is a subdirectory. Handle them differently. + (when (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) + (file-readable-p source) + (not (auto-save-file-name-p source)) + (not (string-equal dir-locals-file + (file-name-nondirectory source)))) + (progn (cl-incf + (pcase (byte-recompile-file source force arg) + (`no-byte-compile skip-count) + (`t file-count) + (_ fail-count))) + (or noninteractive + (message "Checking %s..." directory)) + (if (not (eq last-dir directory)) + (setq last-dir directory + dir-count (1+ dir-count))) + ))))) + (setq directories (cdr directories)))) (message "Done (Total of %d file%s compiled%s%s%s)" file-count (if (= file-count 1) "" "s") (if (> fail-count 0) (format ", %d failed" fail-count) "") @@ -1578,50 +1618,100 @@ that already has a `.elc' file." "Non-nil to prevent byte-compiling of Emacs Lisp code. This is normally set in local file variables at the end of the elisp file: -;; Local Variables:\n;; no-byte-compile: t\n;; End: ") +\;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;Backslash for compile-main. ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) +(defun byte-recompile-file (filename &optional force arg load) + "Recompile FILENAME file if it needs recompilation. +This happens when its `.elc' file is older than itself. + +If the `.elc' file exists and is up-to-date, normally this function +*does not* compile FILENAME. If the prefix argument FORCE is non-nil, +however, it compiles FILENAME even if the destination already +exists and is up-to-date. + +If the `.elc' file does not exist, normally this function *does not* +compile FILENAME. If optional argument ARG is 0, it compiles +the input file even if the `.elc' file does not exist. +Any other non-nil value of ARG means to ask the user. + +If optional argument LOAD is non-nil, loads the file after compiling. + +If compilation is needed, this functions returns the result of +`byte-compile-file'; otherwise it returns 'no-byte-compile." + (interactive + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (derived-mode-p '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 file: " + "Byte recompile file: ") + file-dir file-name nil) + current-prefix-arg))) + (let ((dest (byte-compile-dest-file filename)) + ;; Expand now so we get the current buffer's defaults + (filename (expand-file-name filename))) + (if (if (file-exists-p dest) + ;; File was already compiled + ;; Compile if forced to, or filename newer + (or force + (file-newer-than-file-p filename dest)) + (and arg + (or (eq 0 arg) + (y-or-n-p (concat "Compile " + filename "? "))))) + (progn + (if (and noninteractive (not byte-compile-verbose)) + (message "Compiling %s..." filename)) + (byte-compile-file filename load)) + (when load + (load (if (file-exists-p dest) dest filename))) + 'no-byte-compile))) + ;;;###autoload -(defun byte-compile-file (bytecomp-filename &optional load) - "Compile a file of Lisp code named BYTECOMP-FILENAME into a file of byte code. -The output file's name is generated by passing BYTECOMP-FILENAME to the +(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 generated by passing FILENAME to the function `byte-compile-dest-file' (which see). With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling. The value is non-nil if there were no errors, nil if errors." ;; (interactive "fByte compile file: \nP") (interactive - (let ((bytecomp-file buffer-file-name) - (bytecomp-file-name nil) - (bytecomp-file-dir nil)) - (and bytecomp-file - (eq (cdr (assq 'major-mode (buffer-local-variables))) - 'emacs-lisp-mode) - (setq bytecomp-file-name (file-name-nondirectory bytecomp-file) - bytecomp-file-dir (file-name-directory bytecomp-file))) + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (derived-mode-p '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: ") - bytecomp-file-dir bytecomp-file-name nil) + file-dir file-name nil) current-prefix-arg))) ;; Expand now so we get the current buffer's defaults - (setq bytecomp-filename (expand-file-name bytecomp-filename)) + (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 bytecomp-filename)))) + (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)))) (with-current-buffer b (save-buffer))))) ;; Force logging of the file name for each file compiled. (setq byte-compile-last-logged-file nil) - (let ((byte-compile-current-file bytecomp-filename) + (let ((byte-compile-current-file filename) (byte-compile-current-group nil) (set-auto-coding-for-load t) target-file input-buffer output-buffer byte-compile-dest-file) - (setq target-file (byte-compile-dest-file bytecomp-filename)) + (setq target-file (byte-compile-dest-file filename)) (setq byte-compile-dest-file target-file) (with-current-buffer (setq input-buffer (get-buffer-create " *Compiler Input*")) @@ -1630,7 +1720,7 @@ The value is non-nil if there were no errors, nil if errors." ;; Always compile an Emacs Lisp file as multibyte ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- (set-buffer-multibyte t) - (insert-file-contents bytecomp-filename) + (insert-file-contents filename) ;; Mimic the way after-insert-file-set-coding can make the ;; buffer unibyte when visiting this file. (when (or (eq last-coding-system-used 'no-conversion) @@ -1640,75 +1730,95 @@ The value is non-nil if there were no errors, nil if errors." (set-buffer-multibyte nil)) ;; Run hooks including the uncompression hook. ;; If they change the file name, then change it for the output also. - (letf ((buffer-file-name bytecomp-filename) - ((default-value 'major-mode) 'emacs-lisp-mode) - ;; Ignore unsafe local variables. - ;; We only care about a few of them for our purposes. - (enable-local-variables :safe) - (enable-local-eval nil)) - ;; Arg of t means don't alter enable-local-variables. - (normal-mode t) - (setq bytecomp-filename buffer-file-name)) + (let ((buffer-file-name filename) + (dmm (default-value 'major-mode)) + ;; Ignore unsafe local variables. + ;; We only care about a few of them for our purposes. + (enable-local-variables :safe) + (enable-local-eval nil)) + (unwind-protect + (progn + (setq-default major-mode 'emacs-lisp-mode) + ;; Arg of t means don't alter enable-local-variables. + (normal-mode t)) + (setq-default major-mode dmm)) + ;; There may be a file local variable setting (bug#10419). + (setq buffer-read-only nil + filename buffer-file-name)) + ;; Don't inherit lexical-binding from caller (bug#12938). + (unless (local-variable-p 'lexical-binding) + (setq-local lexical-binding nil)) ;; Set the default directory, in case an eval-when-compile uses it. - (setq default-directory (file-name-directory bytecomp-filename))) + (setq default-directory (file-name-directory filename))) ;; Check if the file's local variables explicitly specify not to ;; compile this file. (if (with-current-buffer input-buffer no-byte-compile) (progn ;; (message "%s not compiled because of `no-byte-compile: %s'" - ;; (file-relative-name bytecomp-filename) + ;; (byte-compile-abbreviate-file filename) ;; (with-current-buffer input-buffer no-byte-compile)) (when (file-exists-p target-file) (message "%s deleted because of `no-byte-compile: %s'" - (file-relative-name target-file) + (byte-compile-abbreviate-file target-file) (buffer-local-value 'no-byte-compile input-buffer)) (condition-case nil (delete-file target-file) (error nil))) ;; We successfully didn't compile this file. 'no-byte-compile) (when byte-compile-verbose - (message "Compiling %s..." bytecomp-filename)) + (message "Compiling %s..." 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 (save-current-buffer - (byte-compile-from-buffer input-buffer bytecomp-filename))) + (byte-compile-from-buffer input-buffer))) (if byte-compiler-error-flag nil (when byte-compile-verbose - (message "Compiling %s...done" bytecomp-filename)) + (message "Compiling %s...done" filename)) (kill-buffer input-buffer) (with-current-buffer output-buffer (goto-char (point-max)) (insert "\n") ; aaah, unix. - (if (file-writable-p target-file) - ;; We must disable any code conversion here. - (let ((coding-system-for-write 'no-conversion)) - (if (memq system-type '(ms-dos 'windows-nt)) - (setq buffer-file-type t)) - (when (file-exists-p target-file) - ;; Remove the target before writing it, so that any - ;; hard-links continue to point to the old file (this makes - ;; it possible for installed files to share disk space with - ;; the build tree, without causing problems when emacs-lisp - ;; files in the build tree are recompiled). - (delete-file target-file)) - (write-region (point-min) (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))) + (if (file-writable-p target-file) + ;; We must disable any code conversion here. + (let* ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile (make-temp-name target-file)) + (kill-emacs-hook + (cons (lambda () (ignore-errors (delete-file tempfile))) + kill-emacs-hook))) + (if (memq system-type '(ms-dos 'windows-nt)) + (setq buffer-file-type t)) + (write-region (point-min) (point-max) tempfile nil 1) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (rename-file tempfile target-file t) + (message "Wrote %s" 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? " - bytecomp-filename)))) + filename)))) (save-excursion - (display-call-tree bytecomp-filename))) + (display-call-tree filename))) (if load (load target-file)) t)))) @@ -1732,18 +1842,16 @@ With argument ARG, insert value in current buffer after the form." (let ((read-with-symbol-positions (current-buffer)) (read-symbol-positions-list nil)) (displaying-byte-compile-warnings - (byte-compile-sexp (read (current-buffer)))))))) + (byte-compile-sexp (read (current-buffer))))) + lexical-binding))) (cond (arg (message "Compiling from buffer... done.") (prin1 value (current-buffer)) (insert "\n")) ((message "%s" (prin1-to-string value))))))) - -(defun byte-compile-from-buffer (bytecomp-inbuffer &optional bytecomp-filename) - ;; Filename is used for the loading-into-Emacs-18 error message. - (let (bytecomp-outbuffer - (byte-compile-current-buffer bytecomp-inbuffer) +(defun byte-compile-from-buffer (inbuffer) + (let ((byte-compile-current-buffer inbuffer) (byte-compile-read-position nil) (byte-compile-last-position nil) ;; Prevent truncation of flonums and lists as we read and print them @@ -1764,29 +1872,24 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-output nil) ;; This allows us to get the positions of symbols read; it's ;; new in Emacs 22.1. - (read-with-symbol-positions bytecomp-inbuffer) + (read-with-symbol-positions inbuffer) (read-symbol-positions-list nil) ;; #### This is bound in b-c-close-variables. ;; (byte-compile-warnings byte-compile-warnings) ) (byte-compile-close-variables (with-current-buffer - (setq bytecomp-outbuffer (get-buffer-create " *Compiler Output*")) + (setq byte-compile--outbuffer + (get-buffer-create " *Compiler Output*")) (set-buffer-multibyte t) (erase-buffer) ;; (emacs-lisp-mode) - (setq case-fold-search nil) - ;; 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)) + (setq case-fold-search nil)) (displaying-byte-compile-warnings - (with-current-buffer bytecomp-inbuffer - (and bytecomp-filename - (byte-compile-insert-header bytecomp-filename bytecomp-outbuffer)) + (with-current-buffer inbuffer + (and byte-compile-current-file + (byte-compile-insert-header byte-compile-current-file + byte-compile--outbuffer)) (goto-char (point-min)) ;; Should we always do this? When calling multiple files, it ;; would be useful to delay this warning until all have been @@ -1803,13 +1906,13 @@ With argument ARG, insert value in current buffer after the form." (setq byte-compile-read-position (point) byte-compile-last-position byte-compile-read-position) (let* ((old-style-backquotes nil) - (form (read bytecomp-inbuffer))) + (form (read inbuffer))) ;; Warn about the use of old-style backquotes. (when old-style-backquotes (byte-compile-warn "!! The file uses old-style backquotes !! This functionality has been obsolete for more than 10 years already and will be removed soon. See (elisp)Backquote in the manual.")) - (byte-compile-file-form form))) + (byte-compile-toplevel-file-form form))) ;; Compile pending forms at end of file. (byte-compile-flush-pending) ;; Make warnings about unresolved functions @@ -1818,12 +1921,12 @@ and will be removed soon. See (elisp)Backquote in the manual.")) (byte-compile-warn-about-unresolved-functions)) ;; Fix up the header at the front of the output ;; if the buffer contains multibyte characters. - (and bytecomp-filename - (with-current-buffer bytecomp-outbuffer - (byte-compile-fix-header bytecomp-filename))))) - bytecomp-outbuffer)) + (and byte-compile-current-file + (with-current-buffer byte-compile--outbuffer + (byte-compile-fix-header byte-compile-current-file)))) + byte-compile--outbuffer))) -(defun byte-compile-fix-header (filename) +(defun byte-compile-fix-header (_filename) "If the current buffer has any multibyte characters, insert a version test." (when (< (point-max) (position-bytes (point-max))) (goto-char (point-min)) @@ -1848,12 +1951,10 @@ and will be removed soon. See (elisp)Backquote in the manual.")) ;; don't try to check the version number. " (< (aref emacs-version (1- (length emacs-version))) ?A)\n" (format " (string-lessp emacs-version \"%s\")\n" minimum-version) - " (error \"`" - ;; prin1-to-string is used to quote backslashes. - (substring (prin1-to-string (file-name-nondirectory filename)) - 1 -1) - (format "' was compiled for Emacs %s or later\"))\n\n" - minimum-version)) + ;; Because the header must fit in a fixed width, we cannot + ;; insert arbitrary-length file names (Bug#11585). + " (error \"`%s' was compiled for " + (format "Emacs %s or later\" #$))\n\n" minimum-version)) ;; Now compensate for any change in size, to make sure all ;; positions in the file remain valid. (setq delta (- (point-max) old-header-end)) @@ -1909,36 +2010,32 @@ Call from the source buffer." ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n" ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")))) -;; Dynamically bound in byte-compile-from-buffer. -;; NB also used in cl.el and cl-macs.el. -(defvar bytecomp-outbuffer) - (defun byte-compile-output-file-form (form) - ;; writes the given form to the output buffer, being careful of docstrings - ;; in defun, defmacro, defvar, defvaralias, defconst, autoload and + ;; Write the given form to the output buffer, being careful of docstrings + ;; in defvar, defvaralias, defconst, autoload and ;; custom-declare-variable 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 defvaralias defconst autoload - custom-declare-variable)) - (stringp (nth 3 form))) - (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil - (memq (car form) - '(defvaralias autoload - custom-declare-variable))) - (let ((print-escape-newlines t) - (print-length nil) - (print-level nil) - (print-quoted t) - (print-gensym t) - (print-circle ; handle circular data structures - (not byte-compile-disable-print-circle))) - (princ "\n" bytecomp-outbuffer) - (prin1 form bytecomp-outbuffer) + (let ((print-escape-newlines t) + (print-length nil) + (print-level nil) + (print-quoted t) + (print-gensym t) + (print-circle ; Handle circular data structures. + (not byte-compile-disable-print-circle))) + (if (and (memq (car-safe form) '(defvar defvaralias defconst + autoload custom-declare-variable)) + (stringp (nth 3 form))) + (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil + (memq (car form) + '(defvaralias autoload + custom-declare-variable))) + (princ "\n" byte-compile--outbuffer) + (prin1 form byte-compile--outbuffer) nil))) -(defvar print-gensym-alist) ;Used before print-circle existed. +(defvar byte-compile--for-effect) (defun byte-compile-output-docform (preface name info form specindex quoted) "Print a form with a doc string. INFO is (prefix doc-index postfix). @@ -1954,7 +2051,7 @@ list that represents a doc string reference. ;; 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)) - (with-current-buffer bytecomp-outbuffer + (with-current-buffer byte-compile--outbuffer (let (position) ;; Insert the doc string, and make it a comment with #@LENGTH. @@ -1967,7 +2064,6 @@ list that represents a doc string reference. (setq position (byte-compile-output-as-comment (nth (nth 1 info) form) nil)) - (setq position (- (position-bytes position) (point-min) -1)) ;; If the doc string starts with * (a user variable), ;; negate POSITION. (if (and (stringp (nth (nth 1 info) form)) @@ -1978,22 +2074,21 @@ list that represents a doc string reference. (if preface (progn (insert preface) - (prin1 name bytecomp-outbuffer))) + (prin1 name byte-compile--outbuffer))) (insert (car info)) - (let ((print-escape-newlines t) - (print-quoted t) - ;; For compatibility with code before print-circle, - ;; use a cons cell to say that we want - ;; print-gensym-alist not to be cleared - ;; between calls to print functions. - (print-gensym '(t)) - (print-circle ; handle circular data structures - (not byte-compile-disable-print-circle)) - print-gensym-alist ; was used before print-circle existed. - (print-continuous-numbering t) + (let ((print-continuous-numbering t) print-number-table - (index 0)) - (prin1 (car form) bytecomp-outbuffer) + (index 0) + ;; FIXME: The bindings below are only needed for when we're + ;; called from ...-defmumble. + (print-escape-newlines t) + (print-length nil) + (print-level nil) + (print-quoted t) + (print-gensym t) + (print-circle ; Handle circular data structures. + (not byte-compile-disable-print-circle))) + (prin1 (car form) byte-compile--outbuffer) (while (setq form (cdr form)) (setq index (1+ index)) (insert " ") @@ -2003,9 +2098,9 @@ list that represents a doc string reference. ;; to objects already output ;; (for instance, gensyms in the arg list). (let (non-nil) - (dotimes (i (length print-number-table)) - (if (aref print-number-table i) - (setq non-nil t))) + (when (hash-table-p print-number-table) + (maphash (lambda (_k v) (if v (setq non-nil t))) + print-number-table)) (not non-nil))) ;; Output the byte code and constants specially ;; for lazy dynamic loading. @@ -2013,37 +2108,38 @@ list that represents a doc string reference. (byte-compile-output-as-comment (cons (car form) (nth 1 form)) t))) - (setq position (- (position-bytes position) (point-min) -1)) - (princ (format "(#$ . %d) nil" position) bytecomp-outbuffer) + (princ (format "(#$ . %d) nil" position) + byte-compile--outbuffer) (setq form (cdr form)) (setq index (1+ index)))) ((= index (nth 1 info)) (if position (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") position) - bytecomp-outbuffer) + byte-compile--outbuffer) (let ((print-escape-newlines nil)) (goto-char (prog1 (1+ (point)) - (prin1 (car form) bytecomp-outbuffer))) + (prin1 (car form) + byte-compile--outbuffer))) (insert "\\\n") (goto-char (point-max))))) (t - (prin1 (car form) bytecomp-outbuffer))))) + (prin1 (car form) byte-compile--outbuffer))))) (insert (nth 2 info))))) nil) -(defun byte-compile-keep-pending (form &optional bytecomp-handler) +(defun byte-compile-keep-pending (form &optional handler) (if (memq byte-optimize '(t source)) (setq form (byte-optimize-form form t))) - (if bytecomp-handler - (let ((for-effect t)) + (if handler + (let ((byte-compile--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 bytecomp-handler form) - (if for-effect + (funcall handler form) + (if byte-compile--for-effect (byte-compile-discard))) (byte-compile-form form t)) nil) @@ -2061,41 +2157,43 @@ list that represents a doc string reference. byte-compile-maxdepth 0 byte-compile-output nil)))) +(defun byte-compile-preprocess (form &optional _for-effect) + (setq form (macroexpand-all form byte-compile-macro-environment)) + ;; FIXME: We should run byte-optimize-form here, but it currently does not + ;; recurse through all the code, so we'd have to fix this first. + ;; Maybe a good fix would be to merge byte-optimize-form into + ;; macroexpand-all. + ;; (if (memq byte-optimize '(t source)) + ;; (setq form (byte-optimize-form form for-effect))) + (if lexical-binding + (cconv-closure-convert form) + form)) + +;; byte-hunk-handlers cannot call this! +(defun byte-compile-toplevel-file-form (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. + (byte-compile-file-form (byte-compile-preprocess form t)))) + +;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) - (let ((byte-compile-current-form nil) ; close over this for warnings. - bytecomp-handler) - (cond - ((not (consp form)) - (byte-compile-keep-pending form)) - ((and (symbolp (car form)) - (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) - (cond ((setq form (funcall bytecomp-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))))) + (let (handler) + (cond ((and (consp form) + (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)))) + (t + (byte-compile-keep-pending form))))) ;; Functions and variables with doc strings must be output separately, -;; so make-docfile can recognise them. Most other things can be output +;; so make-docfile can recognize 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) - (when (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)))) + (while (if (setq form (cdr form)) (macroexp-const-p (car form)))) (null form)) ;Constants only (eval (nth 5 form)) ;Macro (eval form)) ;Define the autoload. @@ -2127,20 +2225,25 @@ list that represents a doc string reference. (put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) (put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) (defun byte-compile-file-form-defvar (form) - (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) - (push (nth 1 form) byte-compile-bound-variables) - (if (eq (car form) 'defconst) - (push (nth 1 form) byte-compile-const-variables)) + (when (and (symbolp (nth 1 form)) + (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) + (byte-compile-warning-enabled-p 'lexical)) + (byte-compile-warn "global/dynamic var `%s' lacks a prefix" + (nth 1 form))) + (push (nth 1 form) byte-compile-bound-variables) + (if (eq (car form) 'defconst) + (push (nth 1 form) byte-compile-const-variables)) + (if (and (null (cddr form)) ;No `value' provided. + (eq (car form) 'defvar)) ;Just a declaration. + nil (cond ((consp (nth 2 form)) - (setq form (copy-sequence form)) - (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file)))) + (setq form (copy-sequence form)) + (setcar (cdr (cdr form)) + (byte-compile-top-level (nth 2 form) nil 'file)))) form)) -(put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-define-abbrev-table) +(put 'define-abbrev-table 'byte-hunk-handler + 'byte-compile-file-form-define-abbrev-table) (defun byte-compile-file-form-define-abbrev-table (form) (if (eq 'quote (car-safe (car-safe (cdr form)))) (push (car-safe (cdr (cadr form))) byte-compile-bound-variables)) @@ -2152,19 +2255,7 @@ list that represents a doc string reference. (when (byte-compile-warning-enabled-p 'callargs) (byte-compile-nogroup-warn form)) (push (nth 1 (nth 1 form)) byte-compile-bound-variables) - ;; Don't compile the expression because it may be displayed to the user. - ;; (when (eq (car-safe (nth 2 form)) 'quote) - ;; ;; (nth 2 form) is meant to evaluate to an expression, so if we have the - ;; ;; final value already, we can byte-compile it. - ;; (setcar (cdr (nth 2 form)) - ;; (byte-compile-top-level (cadr (nth 2 form)) nil 'file))) - (let ((tail (nthcdr 4 form))) - (while tail - (unless (keywordp (car tail)) ;No point optimizing keywords. - ;; Compile the keyword arguments. - (setcar tail (byte-compile-top-level (car tail) nil 'file))) - (setq tail (cdr tail)))) - form) + (byte-compile-keep-pending form)) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) @@ -2211,163 +2302,138 @@ list that represents a doc string reference. (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-defmacro-declaration (form) - "Generate code for declarations in macro definitions. -Remove declarations from the body of the macro definition -by side-effects." - (let ((tail (nthcdr 2 form)) - (res '())) - (when (stringp (car (cdr tail))) - (setq tail (cdr tail))) - (while (and (consp (car (cdr tail))) - (eq (car (car (cdr tail))) 'declare)) - (let ((declaration (car (cdr tail)))) - (setcdr tail (cdr (cdr tail))) - (push `(if macro-declaration-function - (funcall macro-declaration-function - ',(car (cdr form)) ',declaration)) - res))) - res)) - -(defun byte-compile-file-form-defmumble (form macrop) - (let* ((bytecomp-name (car (cdr form))) - (bytecomp-this-kind (if macrop 'byte-compile-macro-environment - 'byte-compile-function-environment)) - (bytecomp-that-kind (if macrop 'byte-compile-function-environment - 'byte-compile-macro-environment)) - (bytecomp-this-one (assq bytecomp-name - (symbol-value bytecomp-this-kind))) - (bytecomp-that-one (assq bytecomp-name - (symbol-value bytecomp-that-kind))) - (byte-compile-free-references nil) - (byte-compile-free-assignments nil)) - (byte-compile-set-symbol-position bytecomp-name) +(defun byte-compile-file-form-defmumble (name macro arglist body rest) + "Process a `defalias' for NAME. +If MACRO is non-nil, the definition is known to be a macro. +ARGLIST is the list of arguments, if it was recognized or t otherwise. +BODY of the definition, or t if not recognized. +Return non-nil if everything went as planned, or nil to imply that it decided +not to take responsibility for the actual compilation of the code." + (let* ((this-kind (if macro 'byte-compile-macro-environment + 'byte-compile-function-environment)) + (that-kind (if macro '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-current-form name)) ; For warnings. + + (byte-compile-set-symbol-position name) ;; 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 bytecomp-name byte-compile-call-tree) - (setq byte-compile-call-tree - (cons (list bytecomp-name nil nil) byte-compile-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 bytecomp-name) ; for warnings (if (byte-compile-warning-enabled-p 'redefine) - (byte-compile-arglist-warn form macrop)) + (byte-compile-arglist-warn name arglist macro)) + (if byte-compile-verbose - ;; bytecomp-filename is from byte-compile-from-buffer. - (message "Compiling %s... (%s)" (or bytecomp-filename "") (nth 1 form))) - (cond (bytecomp-that-one - (if (and (byte-compile-warning-enabled-p 'redefine) - ;; 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 bytecomp-that-one nil)) - (bytecomp-this-one - (when (and (byte-compile-warning-enabled-p 'redefine) - ;; 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 bytecomp-name) - (eq (car-safe (symbol-function bytecomp-name)) - (if macrop 'lambda 'macro))) - (when (byte-compile-warning-enabled-p 'redefine) - (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 bytecomp-this-kind - (cons (cons bytecomp-name nil) - (symbol-value bytecomp-this-kind)))) - ) - (let ((body (nthcdr 3 form))) - (when (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-set-symbol-position (nth 1 form)) - (byte-compile-warn "probable `\"' without `\\' in doc string of %s" - (nth 1 form)))) - - ;; Generate code for declarations in macro definitions. - ;; Remove declarations from the body of the macro definition. - (when macrop - (dolist (decl (byte-compile-defmacro-declaration form)) - (prin1 decl bytecomp-outbuffer))) - - (let* ((new-one (byte-compile-lambda (nthcdr 2 form) t)) - (code (byte-compile-byte-code-maker new-one))) - (if bytecomp-this-one - (setcdr bytecomp-this-one new-one) - (set bytecomp-this-kind - (cons (cons bytecomp-name new-one) - (symbol-value bytecomp-this-kind)))) - (if (and (stringp (nth 3 form)) - (eq 'quote (car-safe code)) - (eq 'lambda (car-safe (nth 1 code)))) - (cons (car form) - (cons bytecomp-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 - "\n(defalias '" - bytecomp-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 - "\n(defalias '" - bytecomp-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 ")" bytecomp-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. + (message "Compiling %s... (%s)" + (or byte-compile-current-file "") name)) + (cond ((not (or macro (listp body))) + ;; We do not know positively if the definition is a macro + ;; or a function, so we shouldn't emit warnings. + ;; This also silences "multiple definition" warnings for defmethods. + nil) + (that-one + (if (and (byte-compile-warning-enabled-p 'redefine) + ;; Don't warn when compiling the stubs in byte-run... + (not (assq name byte-compile-initial-macro-environment))) + (byte-compile-warn + "`%s' defined multiple times, as both function and macro" + name)) + (setcdr that-one nil)) + (this-one + (when (and (byte-compile-warning-enabled-p 'redefine) + ;; Hack: Don't warn when compiling the magic internal + ;; byte-compiler macros in byte-run.el... + (not (assq name byte-compile-initial-macro-environment))) + (byte-compile-warn "%s `%s' defined multiple times in this file" + (if macro "macro" "function") + name))) + ((and (fboundp name) + (eq (car-safe (symbol-function name)) + (if macro 'lambda 'macro))) + (when (byte-compile-warning-enabled-p 'redefine) + (byte-compile-warn "%s `%s' being redefined as a %s" + (if macro "function" "macro") + name + (if macro "macro" "function"))) + ;; Shadow existing definition. + (set this-kind + (cons (cons name nil) + (symbol-value this-kind)))) + ) + + (when (and (listp body) + (stringp (car body)) + (symbolp (car-safe (cdr-safe body))) + (car-safe (cdr-safe body)) + (stringp (car-safe (cdr-safe (cdr-safe body))))) + ;; FIXME: We've done that already just above, so this looks wrong! + ;;(byte-compile-set-symbol-position name) + (byte-compile-warn "probable `\"' without `\\' in doc string of %s" + name)) + + (if (not (listp body)) + ;; The precise definition requires evaluation to find out, so it + ;; will only be known at runtime. + ;; For a macro, that means we can't use that macro in the same file. + (progn + (unless macro + (push (cons name (if (listp arglist) `(declared ,arglist) t)) + byte-compile-function-environment)) + ;; Tell the caller that we didn't compile it yet. + nil) + + (let* ((code (byte-compile-lambda (cons arglist body) t))) + (if this-one + ;; A definition in b-c-initial-m-e should always take precedence + ;; during compilation, so don't let it be redefined. (Bug#8647) + (or (and macro + (assq name byte-compile-initial-macro-environment)) + (setcdr this-one code)) + (set this-kind + (cons (cons name code) + (symbol-value this-kind)))) + + (if rest + ;; There are additional args to `defalias' (like maybe a docstring) + ;; that the code below can't handle: punt! + nil + ;; Otherwise, we have a bona-fide defun/defmacro definition, and use + ;; special code to allow dynamic docstrings and byte-code. + (byte-compile-flush-pending) + (let ((index + ;; If there's no doc string, provide -1 as the "doc string + ;; index" so that no element will be treated as a doc string. + (if (not (stringp (car body))) -1 4))) + ;; Output the form by hand, that's much simpler than having + ;; b-c-output-file-form analyze the defalias. + (byte-compile-output-docform + "\n(defalias '" + name + (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]")) + (append code nil) ; Turn byte-code-function-p into list. + (and (atom code) byte-compile-dynamic + 1) + nil)) + (princ ")" byte-compile--outbuffer) + t))))) + (defun byte-compile-output-as-comment (exp quoted) - (let ((position (point))) - (with-current-buffer bytecomp-outbuffer + "Print Lisp object EXP in the output file, inside a comment, +and return the file (byte) position it will have. +If QUOTED is non-nil, print with quoting; otherwise, print without quoting." + (with-current-buffer byte-compile--outbuffer + (let ((position (point))) ;; Insert EXP, and make it a comment with #@LENGTH. (insert " ") (if quoted - (prin1 exp bytecomp-outbuffer) - (princ exp bytecomp-outbuffer)) + (prin1 exp byte-compile--outbuffer) + (princ exp byte-compile--outbuffer)) (goto-char position) ;; Quote certain special characters as needed. ;; get_doc_string in doc.c does the unquoting. @@ -2386,15 +2452,33 @@ by side-effects." (position-bytes 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)) - - + ;; Note we add 1 to skip the space that we inserted before the actual doc + ;; string, and subtract point-min to convert from an 1-origin Emacs + ;; position to a file position. + (prog1 + (- (position-bytes (point)) (point-min) -1) + (goto-char (point-max)))))) + +(defun byte-compile--reify-function (fun) + "Return an expression which will evaluate to a function value FUN. +FUN should be either a `lambda' value or a `closure' value." + (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil)) + `(closure ,env ,args . ,body)) fun) + (renv ())) + ;; Turn the function's closed vars (if any) into local let bindings. + (dolist (binding env) + (cond + ((consp binding) + ;; We check shadowing by the args, so that the `let' can be moved + ;; within the lambda, which can then be unfolded. FIXME: Some of those + ;; bindings might be unused in `body'. + (unless (memq (car binding) args) ;Shadowed. + (push `(,(car binding) ',(cdr binding)) renv))) + ((eq binding t)) + (t (push `(defvar ,binding) body)))) + (if (null renv) + `(lambda ,args ,@body) + `(lambda ,args (let ,(nreverse renv) ,@body))))) ;;;###autoload (defun byte-compile (form) @@ -2402,74 +2486,45 @@ by side-effects." 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) + (let* ((lexical-binding lexical-binding) + (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))))))) + (cond + ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to + ;; compile something invalid. So let's tune down the complaint from an + ;; error to a simple message for the known case where signaling an error + ;; causes problems. + ((byte-code-function-p fun) + (message "Function %s is already compiled" + (if (symbolp form) form "provided")) + fun) + (t + (when (symbolp form) + (unless (memq (car-safe fun) '(closure lambda)) + (error "Don't know how to compile %S" fun)) + (setq fun (byte-compile--reify-function fun)) + (setq lexical-binding (eq (car fun) 'closure))) + (unless (eq (car-safe fun) 'lambda) + (error "Don't know how to compile %S" fun)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + ;; Get rid of the `function' quote added by the `lambda' macro. + (if (eq (car-safe fun) 'function) (setq fun (cadr fun))) + (setq fun (byte-compile-lambda fun)) + (if macro (push 'macro fun)) + (if (symbolp form) + (fset 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 - ;; ## 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-top-level (byte-compile-preprocess sexp))))) (defun byte-compile-check-lambda-list (list) "Check lambda-list LIST for errors." @@ -2479,7 +2534,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (symbolp arg) (byte-compile-set-symbol-position arg)) (cond ((or (not (symbolp arg)) - (byte-compile-const-symbol-p arg t)) + (macroexp--const-symbol-p arg t)) (error "Invalid lambda variable %s" arg)) ((eq arg '&rest) (unless (cdr list) @@ -2496,85 +2551,132 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq list (cdr list))))) -;; Byte-compile a lambda-expression and return a valid function. -;; The value is usually a compiled function but may be the original -;; lambda-expression. -;; When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head -;; of the list FUN and `byte-compile-set-symbol-position' is not called. -;; Use this feature to avoid calling `byte-compile-set-symbol-position' -;; for symbols generated by the byte compiler itself. -(defun byte-compile-lambda (bytecomp-fun &optional add-lambda) +(defun byte-compile-arglist-vars (arglist) + "Return a list of the variables in the lambda argument list ARGLIST." + (remq '&rest (remq '&optional arglist))) + +(defun byte-compile-make-lambda-lexenv (form) + "Return a new lexical environment for a lambda expression FORM." + ;; See if this is a closure or not + (let ((args (byte-compile-arglist-vars (cadr form)))) + (let ((lexenv nil)) + ;; Fill in the initial stack contents + (let ((stackpos 0)) + ;; Add entries for each argument + (dolist (arg args) + (push (cons arg stackpos) lexenv) + (setq stackpos (1+ stackpos))) + ;; Return the new lexical environment + lexenv)))) + +(defun byte-compile-make-args-desc (arglist) + (let ((mandatory 0) + nonrest (rest 0)) + (while (and arglist (not (memq (car arglist) '(&optional &rest)))) + (setq mandatory (1+ mandatory)) + (setq arglist (cdr arglist))) + (setq nonrest mandatory) + (when (eq (car arglist) '&optional) + (setq arglist (cdr arglist)) + (while (and arglist (not (eq (car arglist) '&rest))) + (setq nonrest (1+ nonrest)) + (setq arglist (cdr arglist)))) + (when arglist + (setq rest 1)) + (if (> mandatory 127) + (byte-compile-report-error "Too many (>127) mandatory arguments") + (logior mandatory + (lsh nonrest 8) + (lsh rest 7))))) + + +(defun byte-compile-lambda (fun &optional add-lambda reserved-csts) + "Byte-compile a lambda-expression and return a valid function. +The value is usually a compiled function but may be the original +lambda-expression. +When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head +of the list FUN and `byte-compile-set-symbol-position' is not called. +Use this feature to avoid calling `byte-compile-set-symbol-position' +for symbols generated by the byte compiler itself." (if add-lambda - (setq bytecomp-fun (cons 'lambda bytecomp-fun)) - (unless (eq 'lambda (car-safe bytecomp-fun)) - (error "Not a lambda list: %S" bytecomp-fun)) + (setq fun (cons 'lambda fun)) + (unless (eq 'lambda (car-safe fun)) + (error "Not a lambda list: %S" fun)) (byte-compile-set-symbol-position 'lambda)) - (byte-compile-check-lambda-list (nth 1 bytecomp-fun)) - (let* ((bytecomp-arglist (nth 1 bytecomp-fun)) + (byte-compile-check-lambda-list (nth 1 fun)) + (let* ((arglist (nth 1 fun)) (byte-compile-bound-variables - (nconc (and (byte-compile-warning-enabled-p 'free-vars) - (delq '&rest - (delq '&optional (copy-sequence bytecomp-arglist)))) - byte-compile-bound-variables)) - (bytecomp-body (cdr (cdr bytecomp-fun))) - (bytecomp-doc (if (stringp (car bytecomp-body)) - (prog1 (car bytecomp-body) - ;; Discard the doc string - ;; unless it is the last element of the body. - (if (cdr bytecomp-body) - (setq bytecomp-body (cdr bytecomp-body)))))) - (bytecomp-int (assq 'interactive bytecomp-body))) + (append (and (not lexical-binding) + (byte-compile-arglist-vars 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 (cdr body) + (setq body (cdr body)))))) + (int (assq 'interactive body))) ;; Process the interactive spec. - (when bytecomp-int + (when int (byte-compile-set-symbol-position 'interactive) ;; Skip (interactive) if it is in front (the most usual location). - (if (eq bytecomp-int (car bytecomp-body)) - (setq bytecomp-body (cdr bytecomp-body))) - (cond ((consp (cdr bytecomp-int)) - (if (cdr (cdr bytecomp-int)) + (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 bytecomp-int))) + (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'. Actually, compile it to get warnings, ;; but don't use the result. - (let ((form (nth 1 bytecomp-int))) + (let* ((form (nth 1 int)) + (newform (byte-compile-top-level form))) (while (memq (car-safe form) '(let let* progn save-excursion)) (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (if (eq (car-safe form) 'list) - (byte-compile-top-level (nth 1 bytecomp-int)) - (setq bytecomp-int (list 'interactive - (byte-compile-top-level - (nth 1 bytecomp-int))))))) - ((cdr bytecomp-int) + (if (and (eq (car-safe form) 'list) + ;; The spec is evalled in callint.c in dynamic-scoping + ;; mode, so just leaving the form unchanged would mean + ;; it won't be eval'd in the right mode. + (not lexical-binding)) + nil + (setq int `(interactive ,newform))))) + ((cdr int) (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string bytecomp-int))))) + (prin1-to-string int))))) ;; Process the body. - (let ((compiled (byte-compile-top-level - (cons 'progn bytecomp-body) nil 'lambda))) + (let ((compiled + (byte-compile-top-level (cons 'progn body) nil 'lambda + ;; If doing lexical binding, push a new + ;; lexical environment containing just the + ;; args (since lambda expressions should be + ;; closed by now). + (and lexical-binding + (byte-compile-make-lambda-lexenv fun)) + reserved-csts))) ;; Build the actual byte-coded function. - (if (eq 'byte-code (car-safe compiled)) - (apply 'make-byte-code - (append (list bytecomp-arglist) - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (if (or bytecomp-doc bytecomp-int) - (list bytecomp-doc)) - ;; optionally, the interactive spec. - (if bytecomp-int - (list (nth 1 bytecomp-int))))) - (setq compiled - (nconc (if bytecomp-int (list bytecomp-int)) - (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) - (compiled (list compiled))))) - (nconc (list 'lambda bytecomp-arglist) - (if (or bytecomp-doc (stringp (car compiled))) - (cons bytecomp-doc (cond (compiled) - (bytecomp-body (list nil)))) - compiled)))))) + (cl-assert (eq 'byte-code (car-safe compiled))) + (apply #'make-byte-code + (if lexical-binding + (byte-compile-make-args-desc arglist) + arglist) + (append + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (cond (lexical-binding + (require 'help-fns) + (list (help-add-fundoc-usage doc arglist))) + ((or doc int) + (list doc))) + ;; optionally, the interactive spec. + (if int + (list (nth 1 int)))))))) + +(defvar byte-compile-reserved-constants 0) (defun byte-compile-constants-vector () ;; Builds the constants-vector from the current variables and constants. @@ -2584,53 +2686,67 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; 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) + (let* ((i (1- byte-compile-reserved-constants)) (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. + 65535 ; 3-byte codes for the rest. + 65535)) ; twice since we step when we swap. 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)) + (while (and rest (< i limit)) + (cond + ((numberp (car rest)) + (cl-assert (< (car rest) byte-compile-reserved-constants))) + ((setq tmp (assq (car (car rest)) ret)) + (setcdr (car rest) (cdr tmp))) + (t (setcdr (car rest) (setq i (1+ i))) - (setq ret (cons (car rest) ret))) + (setq ret (cons (car rest) ret)))) (setq rest (cdr rest))) - (setq limits (cdr limits) - rest (prog1 other + (setq limits (cdr limits) ;Step + rest (prog1 other ;&Swap. (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) +(defun byte-compile-top-level (form &optional for-effect output-type + lexenv reserved-csts) ;; 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) + (let ((byte-compile--for-effect for-effect) + (byte-compile-constants nil) (byte-compile-variables nil) (byte-compile-tag-number 0) (byte-compile-depth 0) (byte-compile-maxdepth 0) + (byte-compile--lexical-environment lexenv) + (byte-compile-reserved-constants (or reserved-csts 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)))) + (if (memq byte-optimize '(t source)) + (setq form (byte-optimize-form form byte-compile--for-effect))) + (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) + (setq form (nth 1 form))) + ;; Set up things for a lexically-bound function. + (when (and lexical-binding (eq output-type 'lambda)) + ;; See how many arguments there are, and set the current stack depth + ;; accordingly. + (setq byte-compile-depth (length byte-compile--lexical-environment)) + ;; If there are args, output a tag to record the initial + ;; stack-depth for the optimizer. + (when (> byte-compile-depth 0) + (byte-compile-out-tag (byte-compile-make-tag)))) + ;; Now compile FORM + (byte-compile-form form byte-compile--for-effect) + (byte-compile-out-toplevel byte-compile--for-effect output-type))) (defun byte-compile-out-toplevel (&optional for-effect output-type) (if for-effect @@ -2652,7 +2768,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (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))) + (byte-optimize-lapcode byte-compile-output))) ;; Decompile trivial functions: ;; only constants and variables, or a single funcall except in lambdas. @@ -2680,34 +2796,35 @@ If FORM is a lambda or a macro, byte-compile it as a function." (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 (byte-compile-const-symbol-p tmp))))) - (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)))))))) + (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 (macroexp--const-symbol-p tmp))))) + (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))) @@ -2717,94 +2834,106 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((cdr body) (cons 'progn (nreverse body))) ((car body))))) -;; Given BYTECOMP-BODY, compile it and return a new body. -(defun byte-compile-top-level-body (bytecomp-body &optional for-effect) - (setq bytecomp-body - (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t)) - (cond ((eq (car-safe bytecomp-body) 'progn) - (cdr bytecomp-body)) - (bytecomp-body - (list bytecomp-body)))) - -(put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function) -(defun byte-compile-declare-function (form) - (push (cons (nth 1 form) - (if (and (> (length form) 3) - (listp (nth 3 form))) - (list 'declared (nth 3 form)) - t)) ; arglist not specified +;; 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)))) + +;; Special macro-expander used during byte-compilation. +(defun byte-compile-macroexpand-declare-function (fn file &rest args) + (push (cons fn + (if (and (consp args) (listp (car args))) + (list 'declared (car args)) + t)) ; Arglist not specified. byte-compile-function-environment) ;; We are stating that it _will_ be defined at runtime. (setq byte-compile-noruntime-functions - (delq (nth 1 form) byte-compile-noruntime-functions)) - nil) + (delq fn byte-compile-noruntime-functions)) + ;; Delegate the rest to the normal macro definition. + (macroexpand `(declare-function ,fn ,file ,@args))) ;; 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). +;; A byte-compile handler may, when byte-compile--for-effect is non-nil, choose +;; output code which does not leave a value on the stack, and then set +;; byte-compile--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.) +;; byte-compile-form, or take extreme care to handle byte-compile--for-effect +;; correctly. (Use byte-compile-form-do-effect to reset the +;; byte-compile--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)) (byte-compile-const-symbol-p form)) - (when (symbolp form) - (byte-compile-set-symbol-position form)) - (byte-compile-constant form)) - ((and for-effect byte-compile-delete-errors) - (when (symbolp form) - (byte-compile-set-symbol-position form)) - (setq for-effect nil)) - (t (byte-compile-variable-ref 'byte-varref form)))) - ((symbolp (car form)) - (let* ((bytecomp-fn (car form)) - (bytecomp-handler (get bytecomp-fn 'byte-compile))) - (when (byte-compile-const-symbol-p bytecomp-fn) - (byte-compile-warn "`%s' called as a function" bytecomp-fn)) - (and (byte-compile-warning-enabled-p 'interactive-only) - (memq bytecomp-fn byte-compile-interactive-only-functions) - (byte-compile-warn "`%s' used from Lisp code\n\ -That command is designed for interactive use only" bytecomp-fn)) - (when (byte-compile-warning-enabled-p 'callargs) - (if (memq bytecomp-fn - '(custom-declare-group custom-declare-variable - custom-declare-face)) - (byte-compile-nogroup-warn form)) - (byte-compile-callargs-warn form)) - (if (and bytecomp-handler - ;; Make sure that function exists. This is important - ;; for CL compiler macros since the symbol may be - ;; `cl-byte-compile-compiler-macro' but if CL isn't - ;; loaded, this function doesn't exist. - (or (not (memq bytecomp-handler - '(cl-byte-compile-compiler-macro))) - (functionp bytecomp-handler))) - (funcall bytecomp-handler form) - (byte-compile-normal-call form)) - (if (byte-compile-warning-enabled-p 'cl-functions) - (byte-compile-cl-warn 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))) + (let ((byte-compile--for-effect for-effect)) + (cond + ((not (consp form)) + (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) + (when (symbolp form) + (byte-compile-set-symbol-position form)) + (byte-compile-constant form)) + ((and byte-compile--for-effect byte-compile-delete-errors) + (when (symbolp form) + (byte-compile-set-symbol-position form)) + (setq byte-compile--for-effect nil)) + (t + (byte-compile-variable-ref form)))) + ((symbolp (car form)) + (let* ((fn (car form)) + (handler (get fn 'byte-compile))) + (when (macroexp--const-symbol-p fn) + (byte-compile-warn "`%s' called as a function" fn)) + (and (byte-compile-warning-enabled-p 'interactive-only) + (memq fn byte-compile-interactive-only-functions) + (byte-compile-warn "`%s' used from Lisp code\n\ +That command is designed for interactive use only" fn)) + (if (and (fboundp (car form)) + (eq (car-safe (symbol-function (car form))) 'macro)) + (byte-compile-log-warning + (format "Forgot to expand macro %s" (car form)) nil :error)) + (if (and handler + ;; Make sure that function exists. + (and (functionp handler) + ;; Ignore obsolete byte-compile function used by former + ;; CL code to handle compiler macros (we do it + ;; differently now). + (not (eq handler 'cl-byte-compile-compiler-macro)))) + (funcall handler form) + (byte-compile-normal-call form)) + (if (byte-compile-warning-enabled-p 'cl-functions) + (byte-compile-cl-warn form)))) + ((and (byte-code-function-p (car form)) + (memq byte-optimize '(t lap))) + (byte-compile-unfold-bcf form)) + ((and (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 byte-compile--for-effect) + (setq byte-compile--for-effect nil)) + ((byte-compile-normal-call form))) + (if byte-compile--for-effect + (byte-compile-discard)))) (defun byte-compile-normal-call (form) + (when (and (byte-compile-warning-enabled-p 'callargs) + (symbolp (car form))) + (if (memq (car form) + '(custom-declare-group custom-declare-variable + custom-declare-face)) + (byte-compile-nogroup-warn form)) + (when (get (car form) 'byte-obsolete-info) + (byte-compile-warn-obsolete (car form))) + (byte-compile-callargs-warn form)) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) - (when (and for-effect (eq (car form) 'mapcar) + (when (and byte-compile--for-effect (eq (car form) 'mapcar) (byte-compile-warning-enabled-p 'mapcar)) (byte-compile-set-symbol-position 'mapcar) (byte-compile-warn @@ -2813,44 +2942,147 @@ That command is designed for interactive use only" bytecomp-fn)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (byte-compile-out 'byte-call (length (cdr form)))) -(defun byte-compile-variable-ref (base-op bytecomp-var) - (when (symbolp bytecomp-var) - (byte-compile-set-symbol-position bytecomp-var)) - (if (or (not (symbolp bytecomp-var)) - (byte-compile-const-symbol-p bytecomp-var - (not (eq base-op 'byte-varref)))) - (if (byte-compile-warning-enabled-p 'constants) - (byte-compile-warn - (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'") - ((eq base-op 'byte-varset) "variable assignment to %s `%s'") - (t "variable reference to %s `%s'")) - (if (symbolp bytecomp-var) "constant" "nonvariable") - (prin1-to-string bytecomp-var))) - (and (get bytecomp-var 'byte-obsolete-variable) - (not (memq bytecomp-var byte-compile-not-obsolete-vars)) - (byte-compile-warn-obsolete bytecomp-var)) - (if (eq base-op 'byte-varbind) - (push bytecomp-var byte-compile-bound-variables) - (or (not (byte-compile-warning-enabled-p 'free-vars)) - (boundp bytecomp-var) - (memq bytecomp-var byte-compile-bound-variables) - (if (eq base-op 'byte-varset) - (or (memq bytecomp-var byte-compile-free-assignments) - (progn - (byte-compile-warn "assignment to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-assignments))) - (or (memq bytecomp-var byte-compile-free-references) - (progn - (byte-compile-warn "reference to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-references))))))) - (let ((tmp (assq bytecomp-var byte-compile-variables))) + +;; 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-compile-inline-lapcode (lap end-depth) + ;; "Replay" the operations: we used to just do + ;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output)) + ;; but that fails to update byte-compile-depth, so we had to assume + ;; that `lap' ends up adding exactly 1 element to the stack. This + ;; happens to be true for byte-code generated by bytecomp.el without + ;; lexical-binding, but it's not true in general, and it's not true for + ;; code output by bytecomp.el with lexical-binding. + (let ((endtag (byte-compile-make-tag))) + (dolist (op lap) + (cond + ((eq (car op) 'TAG) (byte-compile-out-tag op)) + ((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op))) + ((eq (car op) 'byte-return) + (byte-compile-discard (- byte-compile-depth end-depth) t) + (byte-compile-goto 'byte-goto endtag)) + (t (byte-compile-out (car op) (cdr op))))) + (byte-compile-out-tag endtag))) + +(defun byte-compile-unfold-bcf (form) + "Inline call to byte-code-functions." + (let* ((byte-compile-bound-variables byte-compile-bound-variables) + (fun (car form)) + (fargs (aref fun 0)) + (start-depth byte-compile-depth) + (fmax2 (if (numberp fargs) (lsh fargs -7))) ;2*max+rest. + ;; (fmin (if (numberp fargs) (logand fargs 127))) + (alen (length (cdr form))) + (dynbinds ())) + (fetch-bytecode fun) + (mapc 'byte-compile-form (cdr form)) + (unless fmax2 + ;; Old-style byte-code. + (cl-assert (listp fargs)) + (while fargs + (pcase (car fargs) + (`&optional (setq fargs (cdr fargs))) + (`&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1)) + (push (cadr fargs) dynbinds) + (setq fargs nil)) + (_ (push (pop fargs) dynbinds)))) + (unless fmax2 (setq fmax2 (* 2 (length dynbinds))))) + (cond + ((<= (+ alen alen) fmax2) + ;; Add missing &optional (or &rest) arguments. + (dotimes (_ (- (/ (1+ fmax2) 2) alen)) + (byte-compile-push-constant nil))) + ((zerop (logand fmax2 1)) + (byte-compile-log-warning "Too many arguments for inlined function" + nil :error) + (byte-compile-discard (- alen (/ fmax2 2)))) + (t + ;; Turn &rest args into a list. + (let ((n (- alen (/ (1- fmax2) 2)))) + (cl-assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n) + (if (< n 5) + (byte-compile-out + (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- n)) + 0) + (byte-compile-out 'byte-listN n))))) + (mapc #'byte-compile-dynamic-variable-bind dynbinds) + (byte-compile-inline-lapcode + (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t) + (1+ start-depth)) + ;; Unbind dynamic variables. + (when dynbinds + (byte-compile-out 'byte-unbind (length dynbinds))) + (cl-assert (eq byte-compile-depth (1+ start-depth)) + nil "Wrong depth start=%s end=%s" start-depth byte-compile-depth))) + +(defun byte-compile-check-variable (var access-type) + "Do various error checks before a use of the variable VAR." + (when (symbolp var) + (byte-compile-set-symbol-position var)) + (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) + (when (byte-compile-warning-enabled-p 'constants) + (byte-compile-warn (if (eq access-type 'let-bind) + "attempt to let-bind %s `%s`" + "variable reference to %s `%s'") + (if (symbolp var) "constant" "nonvariable") + (prin1-to-string var)))) + ((let ((od (get var 'byte-obsolete-variable))) + (and od + (not (memq var byte-compile-not-obsolete-vars)) + (not (memq var byte-compile-global-not-obsolete-vars)) + (or (pcase (nth 1 od) + (`set (not (eq access-type 'reference))) + (`get (eq access-type 'reference)) + (_ t))))) + (byte-compile-warn-obsolete var)))) + +(defsubst byte-compile-dynamic-variable-op (base-op var) + (let ((tmp (assq var byte-compile-variables))) (unless tmp - (setq tmp (list bytecomp-var)) + (setq tmp (list var)) (push tmp byte-compile-variables)) (byte-compile-out base-op tmp))) +(defun byte-compile-dynamic-variable-bind (var) + "Generate code to bind the lexical variable VAR to the top-of-stack value." + (byte-compile-check-variable var 'let-bind) + (push var byte-compile-bound-variables) + (byte-compile-dynamic-variable-op 'byte-varbind var)) + +(defun byte-compile-variable-ref (var) + "Generate code to push the value of the variable VAR on the stack." + (byte-compile-check-variable var 'reference) + (let ((lex-binding (assq var byte-compile--lexical-environment))) + (if lex-binding + ;; VAR is lexically bound + (byte-compile-stack-ref (cdr lex-binding)) + ;; VAR is dynamically bound + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-references)) + (byte-compile-warn "reference to free variable `%S'" var) + (push var byte-compile-free-references)) + (byte-compile-dynamic-variable-op 'byte-varref var)))) + +(defun byte-compile-variable-set (var) + "Generate code to set the variable VAR from the top-of-stack value." + (byte-compile-check-variable var 'assign) + (let ((lex-binding (assq var byte-compile--lexical-environment))) + (if lex-binding + ;; VAR is lexically bound. + (byte-compile-stack-set (cdr lex-binding)) + ;; VAR is dynamically bound. + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-assignments)) + (byte-compile-warn "assignment to free variable `%s'" var) + (push var byte-compile-free-assignments)) + (byte-compile-dynamic-variable-op 'byte-varset var)))) + (defmacro byte-compile-get-constant (const) `(or (if (stringp ,const) ;; In a string constant, treat properties as significant. @@ -2863,20 +3095,20 @@ That command is designed for interactive use only" bytecomp-fn)) (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. +;; Use this when the value of a form is a constant. +;; This obeys byte-compile--for-effect. (defun byte-compile-constant (const) - (if for-effect - (setq for-effect nil) + (if byte-compile--for-effect + (setq byte-compile--for-effect nil) (when (symbolp const) (byte-compile-set-symbol-position const)) (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. +;; This ignores byte-compile--for-effect. (defun byte-compile-push-constant (const) - (let ((for-effect nil)) + (let ((byte-compile--for-effect nil)) (inline (byte-compile-constant const)))) - ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -2947,7 +3179,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (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-compiler interactive-p 0) ;; Obsolete. (byte-defop-compiler widen 0) (byte-defop-compiler end-of-line 0-1) (byte-defop-compiler forward-char 0-1) @@ -3030,7 +3262,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (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. + ;; Get run-time wrong-number-of-args error. (byte-compile-normal-call form)) (defun byte-compile-no-args (form) @@ -3077,12 +3309,67 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" ((= len 4) (byte-compile-three-args form)) (t (byte-compile-subr-wrong-args form "2-3"))))) -(defun byte-compile-noop (form) +(defun byte-compile-noop (_form) (byte-compile-constant nil)) -(defun byte-compile-discard () - (byte-compile-out 'byte-discard 0)) - +(defun byte-compile-discard (&optional num preserve-tos) + "Output byte codes to discard the NUM entries at the top of the stack. +NUM defaults to 1. +If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were +popped before discarding the num values, and then pushed back again after +discarding." + (if (and (null num) (not preserve-tos)) + ;; common case + (byte-compile-out 'byte-discard) + ;; general case + (unless num + (setq num 1)) + (when (and preserve-tos (> num 0)) + ;; Preserve the top-of-stack value by writing it directly to the stack + ;; location which will be at the top-of-stack after popping. + (byte-compile-stack-set (1- (- byte-compile-depth num))) + ;; Now we actually discard one less value, since we want to keep + ;; the eventual TOS + (setq num (1- num))) + (while (> num 0) + (byte-compile-out 'byte-discard) + (setq num (1- num))))) + +(defun byte-compile-stack-ref (stack-pos) + "Output byte codes to push the value at stack position STACK-POS." + (let ((dist (- byte-compile-depth (1+ stack-pos)))) + (if (zerop dist) + ;; A simple optimization + (byte-compile-out 'byte-dup) + ;; normal case + (byte-compile-out 'byte-stack-ref dist)))) + +(defun byte-compile-stack-set (stack-pos) + "Output byte codes to store the TOS value at stack position STACK-POS." + (byte-compile-out 'byte-stack-set (- byte-compile-depth (1+ stack-pos)))) + +(byte-defop-compiler-1 internal-make-closure byte-compile-make-closure) +(byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var) + +(defun byte-compile-make-closure (form) + "Byte-compile the special `internal-make-closure' form." + (if byte-compile--for-effect (setq byte-compile--for-effect nil) + (let* ((vars (nth 1 form)) + (env (nth 2 form)) + (body (nthcdr 3 form)) + (fun + (byte-compile-lambda `(lambda ,vars . ,body) nil (length env)))) + (cl-assert (> (length env) 0)) ;Otherwise, we don't need a closure. + (cl-assert (byte-code-function-p fun)) + (byte-compile-form `(make-byte-code + ',(aref fun 0) ',(aref fun 1) + (vconcat (vector . ,env) ',(aref fun 2)) + ,@(nthcdr 3 (mapcar (lambda (x) `',x) fun))))))) + +(defun byte-compile-get-closed-var (form) + "Byte-compile the special `internal-get-closed-var' form." + (if byte-compile--for-effect (setq byte-compile--for-effect nil) + (byte-compile-out 'byte-constant (nth 1 form)))) ;; Compile a function that accepts one or more args and is right-associative. ;; We do it by left-associativity so that the operations @@ -3237,43 +3524,17 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (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."))))) + the syntax #'(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)) - ((byte-compile-lambda (nth 1 form)))))) + (byte-compile-constant (if (eq 'lambda (car-safe (nth 1 form))) + (byte-compile-lambda (nth 1 form)) + (nth 1 form)))) (defun byte-compile-indent-to (form) (let ((len (length form))) @@ -3308,60 +3569,67 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (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 ((bytecomp-args (cdr form))) - (if bytecomp-args - (while bytecomp-args - (byte-compile-form (car (cdr bytecomp-args))) - (or for-effect (cdr (cdr bytecomp-args)) + (let ((args (cdr form))) + (if args + (while args + (byte-compile-form (car (cdr args))) + (or byte-compile--for-effect (cdr (cdr args)) (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-ref 'byte-varset (car bytecomp-args)) - (setq bytecomp-args (cdr (cdr bytecomp-args)))) + (byte-compile-variable-set (car args)) + (setq args (cdr (cdr args)))) ;; (setq), with no arguments. - (byte-compile-form nil for-effect)) - (setq for-effect nil))) + (byte-compile-form nil byte-compile--for-effect)) + (setq byte-compile--for-effect nil))) (defun byte-compile-setq-default (form) - (let ((bytecomp-args (cdr form)) - setters) - (while bytecomp-args - (let ((var (car bytecomp-args))) + (setq form (cdr form)) + (if (null form) ; (setq-default), with no arguments + (byte-compile-form nil byte-compile--for-effect) + (if (> (length form) 2) + (let ((setters ())) + (while (consp form) + (push `(setq-default ,(pop form) ,(pop form)) setters)) + (byte-compile-form (cons 'progn (nreverse setters)))) + (let ((var (car form))) (and (or (not (symbolp var)) - (byte-compile-const-symbol-p var t)) + (macroexp--const-symbol-p var t)) (byte-compile-warning-enabled-p 'constants) (byte-compile-warn "variable assignment to %s `%s'" (if (symbolp var) "constant" "nonvariable") (prin1-to-string var))) - (push (list 'set-default (list 'quote var) (car (cdr bytecomp-args))) - setters)) - (setq bytecomp-args (cdr (cdr bytecomp-args)))) - (byte-compile-form (cons 'progn (nreverse setters))))) + (byte-compile-normal-call `(set-default ',var ,@(cdr form))))))) + +(byte-defop-compiler-1 set-default) +(defun byte-compile-set-default (form) + (let ((varexp (car-safe (cdr-safe form)))) + (if (eq (car-safe varexp) 'quote) + ;; If the varexp is constant, compile it as a setq-default + ;; so we get more warnings. + (byte-compile-setq-default `(setq-default ,(car-safe (cdr varexp)) + ,@(cddr form))) + (byte-compile-normal-call form)))) (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 (bytecomp-body &optional for-effect) - (while (cdr bytecomp-body) - (byte-compile-form (car bytecomp-body) t) - (setq bytecomp-body (cdr bytecomp-body))) - (byte-compile-form (car bytecomp-body) for-effect)) +(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 (bytecomp-body) - (byte-compile-body bytecomp-body for-effect) - (setq for-effect nil)) +(defsubst byte-compile-body-do-effect (body) + (byte-compile-body body byte-compile--for-effect) + (setq byte-compile--for-effect nil)) (defsubst byte-compile-form-do-effect (form) - (byte-compile-form form for-effect) - (setq for-effect nil)) + (byte-compile-form form byte-compile--for-effect) + (setq byte-compile--for-effect nil)) (byte-defop-compiler-1 inline byte-compile-progn) (byte-defop-compiler-1 progn) @@ -3373,18 +3641,8 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (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 mapc byte-compile-funarg) -(byte-defop-compiler-1 maphash byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg-2) -;; map-charset-chars should be funarg but has optional third arg -(byte-defop-compiler-1 sort byte-compile-funarg-2) (byte-defop-compiler-1 let) -(byte-defop-compiler-1 let*) +(byte-defop-compiler-1 let* byte-compile-let) (defun byte-compile-progn (form) (byte-compile-body-do-effect (cdr form))) @@ -3449,13 +3707,11 @@ that suppresses all warnings during execution of BODY." ,condition (list 'boundp 'default-boundp))) ;; Maybe add to the bound list. (byte-compile-bound-variables - (if bound-list - (append bound-list byte-compile-bound-variables) - byte-compile-bound-variables))) + (append bound-list byte-compile-bound-variables))) (unwind-protect - ;; If things not being bound at all is ok, so must them being obsolete. - ;; Note that we add to the existing lists since Tramp (ab)uses - ;; this feature. + ;; If things not being bound at all is ok, so must them being + ;; obsolete. Note that we add to the existing lists since Tramp + ;; (ab)uses this feature. (let ((byte-compile-not-obsolete-vars (append byte-compile-not-obsolete-vars bound-list)) (byte-compile-not-obsolete-funcs @@ -3471,26 +3727,26 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-if (form) (byte-compile-form (car (cdr form))) ;; Check whether we have `(if (fboundp ...' or `(if (boundp ...' - ;; and avoid warnings about the relevent symbols in the consequent. + ;; and avoid warnings about the relevant symbols in the consequent. (let ((clause (nth 1 form)) (donetag (byte-compile-make-tag))) (if (null (nthcdr 3 form)) ;; No else-forms (progn - (byte-compile-goto-if nil for-effect donetag) + (byte-compile-goto-if nil byte-compile--for-effect donetag) (byte-compile-maybe-guarded clause - (byte-compile-form (nth 2 form) for-effect)) + (byte-compile-form (nth 2 form) byte-compile--for-effect)) (byte-compile-out-tag donetag)) (let ((elsetag (byte-compile-make-tag))) (byte-compile-goto 'byte-goto-if-nil elsetag) (byte-compile-maybe-guarded clause - (byte-compile-form (nth 2 form) for-effect)) + (byte-compile-form (nth 2 form) byte-compile--for-effect)) (byte-compile-goto 'byte-goto donetag) (byte-compile-out-tag elsetag) (byte-compile-maybe-guarded (list 'not clause) - (byte-compile-body (cdr (cdr (cdr form))) for-effect)) + (byte-compile-body (cdr (cdr (cdr form))) byte-compile--for-effect)) (byte-compile-out-tag donetag)))) - (setq for-effect nil)) + (setq byte-compile--for-effect nil)) (defun byte-compile-cond (clauses) (let ((donetag (byte-compile-make-tag)) @@ -3507,18 +3763,18 @@ that suppresses all warnings during execution of BODY." (byte-compile-form (car clause)) (if (null (cdr clause)) ;; First clause is a singleton. - (byte-compile-goto-if t for-effect donetag) + (byte-compile-goto-if t byte-compile--for-effect donetag) (setq nexttag (byte-compile-make-tag)) (byte-compile-goto 'byte-goto-if-nil nexttag) (byte-compile-maybe-guarded (car clause) - (byte-compile-body (cdr clause) for-effect)) + (byte-compile-body (cdr clause) byte-compile--for-effect)) (byte-compile-goto 'byte-goto donetag) (byte-compile-out-tag nexttag))))) ;; Last clause (let ((guard (car clause))) (and (cdr clause) (not (eq guard t)) (progn (byte-compile-form guard) - (byte-compile-goto-if nil for-effect donetag) + (byte-compile-goto-if nil byte-compile--for-effect donetag) (setq clause (cdr clause)))) (byte-compile-maybe-guarded guard (byte-compile-body-do-effect clause))) @@ -3526,10 +3782,10 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-and (form) (let ((failtag (byte-compile-make-tag)) - (bytecomp-args (cdr form))) - (if (null bytecomp-args) + (args (cdr form))) + (if (null args) (byte-compile-form-do-effect t) - (byte-compile-and-recursion bytecomp-args failtag)))) + (byte-compile-and-recursion args failtag)))) ;; Handle compilation of a nontrivial `and' call. ;; We use tail recursion so we can use byte-compile-maybe-guarded. @@ -3537,7 +3793,7 @@ that suppresses all warnings during execution of BODY." (if (cdr rest) (progn (byte-compile-form (car rest)) - (byte-compile-goto-if nil for-effect failtag) + (byte-compile-goto-if nil byte-compile--for-effect failtag) (byte-compile-maybe-guarded (car rest) (byte-compile-and-recursion (cdr rest) failtag))) (byte-compile-form-do-effect (car rest)) @@ -3545,10 +3801,10 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-or (form) (let ((wintag (byte-compile-make-tag)) - (bytecomp-args (cdr form))) - (if (null bytecomp-args) + (args (cdr form))) + (if (null args) (byte-compile-form-do-effect nil) - (byte-compile-or-recursion bytecomp-args wintag)))) + (byte-compile-or-recursion args wintag)))) ;; Handle compilation of a nontrivial `or' call. ;; We use tail recursion so we can use byte-compile-maybe-guarded. @@ -3556,7 +3812,7 @@ that suppresses all warnings during execution of BODY." (if (cdr rest) (progn (byte-compile-form (car rest)) - (byte-compile-goto-if t for-effect wintag) + (byte-compile-goto-if t byte-compile--for-effect wintag) (byte-compile-maybe-guarded (list 'not (car rest)) (byte-compile-or-recursion (cdr rest) wintag))) (byte-compile-form-do-effect (car rest)) @@ -3567,44 +3823,131 @@ that suppresses all warnings during execution of BODY." (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-goto-if nil byte-compile--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))) + (setq byte-compile--for-effect nil))) (defun byte-compile-funcall (form) (mapc 'byte-compile-form (cdr form)) (byte-compile-out 'byte-call (length (cdr (cdr form))))) + +;; let binding + +(defun byte-compile-push-binding-init (clause) + "Emit byte-codes to push the initialization value for CLAUSE on the stack. +Return the offset in the form (VAR . OFFSET)." + (let* ((var (if (consp clause) (car clause) clause))) + ;; We record the stack position even of dynamic bindings and + ;; variables in non-stack lexical environments; we'll put + ;; them in the proper place below. + (prog1 (cons var byte-compile-depth) + (if (consp clause) + (byte-compile-form (cadr clause)) + (byte-compile-push-constant nil))))) + +(defun byte-compile-not-lexical-var-p (var) + (or (not (symbolp var)) + (special-variable-p var) + (memq var byte-compile-bound-variables) + (memq var '(nil t)) + (keywordp var))) + +(defun byte-compile-bind (var init-lexenv) + "Emit byte-codes to bind VAR and update `byte-compile--lexical-environment'. +INIT-LEXENV should be a lexical-environment alist describing the +positions of the init value that have been pushed on the stack. +Return non-nil if the TOS value was popped." + ;; The presence of lexical bindings mean that we may have to + ;; juggle things on the stack, to move them to TOS for + ;; dynamic binding. + (cond ((not (byte-compile-not-lexical-var-p var)) + ;; VAR is a simple stack-allocated lexical variable + (push (assq var init-lexenv) + byte-compile--lexical-environment) + nil) + ((eq var (caar init-lexenv)) + ;; VAR is dynamic and is on the top of the + ;; stack, so we can just bind it like usual + (byte-compile-dynamic-variable-bind var) + t) + (t + ;; VAR is dynamic, but we have to get its + ;; value out of the middle of the stack + (let ((stack-pos (cdr (assq var init-lexenv)))) + (byte-compile-stack-ref stack-pos) + (byte-compile-dynamic-variable-bind var) + ;; Now we have to store nil into its temporary + ;; stack position to avoid problems with GC + (byte-compile-push-constant nil) + (byte-compile-stack-set stack-pos)) + nil))) + +(defun byte-compile-unbind (clauses init-lexenv + &optional preserve-body-value) + "Emit byte-codes to unbind the variables bound by CLAUSES. +CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a +lexical-environment alist describing the positions of the init value that +have been pushed on the stack. If PRESERVE-BODY-VALUE is true, +then an additional value on the top of the stack, above any lexical binding +slots, is preserved, so it will be on the top of the stack after all +binding slots have been popped." + ;; Unbind dynamic variables + (let ((num-dynamic-bindings 0)) + (dolist (clause clauses) + (unless (assq (if (consp clause) (car clause) clause) + byte-compile--lexical-environment) + (setq num-dynamic-bindings (1+ num-dynamic-bindings)))) + (unless (zerop num-dynamic-bindings) + (byte-compile-out 'byte-unbind num-dynamic-bindings))) + ;; Pop lexical variables off the stack, possibly preserving the + ;; return value of the body. + (when init-lexenv + ;; INIT-LEXENV contains all init values left on the stack + (byte-compile-discard (length init-lexenv) preserve-body-value))) (defun byte-compile-let (form) - ;; First compute the binding values in the old scope. - (let ((varlist (car (cdr form)))) - (dolist (var varlist) - (if (consp var) - (byte-compile-form (car (cdr var))) - (byte-compile-push-constant nil)))) - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (reverse (car (cdr form))))) - (dolist (var varlist) - (byte-compile-variable-ref 'byte-varbind - (if (consp var) (car var) var))) - (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))))) - (dolist (var varlist) - (if (atom var) - (byte-compile-push-constant nil) - (byte-compile-form (car (cdr var))) - (setq var (car var))) - (byte-compile-variable-ref 'byte-varbind var)) - (byte-compile-body-do-effect (cdr (cdr form))) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) + "Generate code for the `let' form FORM." + (let ((clauses (cadr form)) + (init-lexenv nil)) + (when (eq (car form) 'let) + ;; First compute the binding values in the old scope. + (dolist (var clauses) + (push (byte-compile-push-binding-init var) init-lexenv))) + ;; New scope. + (let ((byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile--lexical-environment + byte-compile--lexical-environment)) + ;; Bind the variables. + ;; For `let', do it in reverse order, because it makes no + ;; semantic difference, but it is a lot more efficient since the + ;; values are now in reverse order on the stack. + (dolist (var (if (eq (car form) 'let) (reverse clauses) clauses)) + (unless (eq (car form) 'let) + (push (byte-compile-push-binding-init var) init-lexenv)) + (let ((var (if (consp var) (car var) var))) + (cond ((null lexical-binding) + ;; If there are no lexical bindings, we can do things simply. + (byte-compile-dynamic-variable-bind var)) + ((byte-compile-bind var init-lexenv) + (pop init-lexenv))))) + ;; Emit the body. + (let ((init-stack-depth byte-compile-depth)) + (byte-compile-body-do-effect (cdr (cdr form))) + ;; Unbind the variables. + (if lexical-binding + ;; Unbind both lexical and dynamic variables. + (progn + (cl-assert (or (eq byte-compile-depth init-stack-depth) + (eq byte-compile-depth (1+ init-stack-depth)))) + (byte-compile-unbind clauses init-lexenv (> byte-compile-depth + init-stack-depth))) + ;; Unbind dynamic variables. + (byte-compile-out 'byte-unbind (length clauses))))))) + (byte-defop-compiler-1 /= byte-compile-negated) (byte-defop-compiler-1 atom byte-compile-negated) @@ -3636,77 +3979,94 @@ that suppresses all warnings during execution of BODY." (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 save-window-excursion) ;Obsolete: now a macro. +;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro. (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)) + (pcase (cddr form) + (`(:fun-body ,f) + (byte-compile-form `(list 'funcall ,f))) + (body + (byte-compile-push-constant + (byte-compile-top-level (cons 'progn body) byte-compile--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)) + (pcase (cddr form) + (`(:fun-body ,f) + (byte-compile-form `(list (list 'funcall ,f)))) + (handlers + (byte-compile-push-constant + (byte-compile-top-level-body handlers 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 - `(funcall '(lambda nil - (track-mouse ,@(byte-compile-top-level-body (cdr form))))))) + (pcase form + (`(,_ :fun-body ,f) `(eval (list 'track-mouse (list 'funcall ,f)))) + (_ `(eval '(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) + (fun-bodies (eq var :fun-body)) + (byte-compile-bound-variables + (if (and var (not fun-bodies)) + (cons var byte-compile-bound-variables) byte-compile-bound-variables))) (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) (byte-compile-warn "`%s' is not a variable-name or nil (in condition-case)" var)) + (if fun-bodies (setq var (make-symbol "err"))) (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))) + (if fun-bodies + (byte-compile-form `(list 'funcall ,(nth 2 form))) + (byte-compile-push-constant + (byte-compile-top-level (nth 2 form) byte-compile--for-effect))) + (let ((compiled-clauses + (mapcar + (lambda (clause) + (let ((condition (car clause))) + (cond ((not (or (symbolp condition) + (and (listp condition) + (let ((ok t)) + (dolist (sym condition) + (if (not (symbolp sym)) + (setq ok nil))) + ok)))) + (byte-compile-warn + "`%S' is not a condition name or list of such (in condition-case)" + 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)) + ) + (if fun-bodies + `(list ',condition (list 'funcall ,(cadr clause) ',var)) + (cons condition + (byte-compile-top-level-body + (cdr clause) byte-compile--for-effect))))) + (cdr (cdr (cdr form)))))) + (if fun-bodies + (byte-compile-form `(list ,@compiled-clauses)) + (byte-compile-push-constant compiled-clauses))) (byte-compile-out 'byte-condition-case 0))) (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) (byte-compile-warning-enabled-p 'suspicious)) - (byte-compile-warn "`save-excursion' defeated by `set-buffer'")) + (byte-compile-warn + "Use `with-current-buffer' rather than save-excursion+set-buffer")) (byte-compile-out 'byte-save-excursion 0) (byte-compile-body-do-effect (cdr form)) (byte-compile-out 'byte-unbind 1)) @@ -3720,58 +4080,34 @@ that suppresses all warnings during execution of BODY." (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) -(defun byte-compile-defun (form) - ;; This is not used for file-level defuns with doc strings. - (if (symbolp (car form)) - (byte-compile-set-symbol-position (car form)) - (byte-compile-set-symbol-position 'defun) - (error "defun name must be a symbol, not %s" (car form))) - ;; We prefer to generate a defalias form so it will record the function - ;; definition just like interpreting a defun. - (byte-compile-form - (list 'defalias - (list 'quote (nth 1 form)) - (byte-compile-byte-code-maker - (byte-compile-lambda (cdr (cdr form)) t))) - t) - (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 - (let ((decls (byte-compile-defmacro-declaration form)) - (code (byte-compile-byte-code-maker - (byte-compile-lambda (cdr (cdr form)) t)))) - `((defalias ',(nth 1 form) - ,(if (eq (car-safe code) 'make-byte-code) - `(cons 'macro ,code) - `'(macro . ,(eval code)))) - ,@decls - ',(nth 1 form))))) +;; If foo.el declares `toto' as obsolete, it is likely that foo.el will +;; actually use `toto' in order for this obsolete variable to still work +;; correctly, so paradoxically, while byte-compiling foo.el, the presence +;; of a make-obsolete-variable call for `toto' is an indication that `toto' +;; should not trigger obsolete-warnings in foo.el. +(byte-defop-compiler-1 make-obsolete-variable) +(defun byte-compile-make-obsolete-variable (form) + (when (eq 'quote (car-safe (nth 1 form))) + (push (nth 1 (nth 1 form)) byte-compile-global-not-obsolete-vars)) + (byte-compile-normal-call form)) + +(defconst byte-compile-tmp-var (make-symbol "def-tmp-var")) (defun byte-compile-defvar (form) - ;; This is not used for file-level defvar/consts with doc strings. + ;; This is not used for file-level defvar/consts. + (when (and (symbolp (nth 1 form)) + (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) + (byte-compile-warning-enabled-p 'lexical)) + (byte-compile-warn "global/dynamic var `%s' lacks a prefix" + (nth 1 form))) (let ((fun (nth 0 form)) (var (nth 1 form)) (value (nth 2 form)) @@ -3789,35 +4125,26 @@ that suppresses all warnings during execution of BODY." (push var byte-compile-bound-variables) (if (eq fun 'defconst) (push var byte-compile-const-variables)) - (byte-compile-body-do-effect - (list - ;; Put the defined variable in this library's load-history entry - ;; just as a real defvar would, but only in top-level forms. - (when (and (cddr form) (null byte-compile-current-form)) - `(push ',var current-load-list)) - (when (> (length form) 3) - (when (and string (not (stringp string))) - (byte-compile-warn "third arg to `%s %s' is not a string: %s" - fun var string)) - `(put ',var 'variable-documentation ,string)) - (if (cddr form) ; `value' provided - (let ((byte-compile-not-obsolete-vars (list var))) - (if (eq fun 'defconst) - ;; `defconst' sets `var' unconditionally. - (let ((tmp (make-symbol "defconst-tmp-var"))) - `(funcall '(lambda (,tmp) (defconst ,var ,tmp)) - ,value)) - ;; `defvar' sets `var' only when unbound. - `(if (not (default-boundp ',var)) (setq-default ,var ,value)))) - (when (eq fun 'defconst) - ;; This will signal an appropriate error at runtime. - `(eval ',form))) - `',var)))) + (when (and string (not (stringp string))) + (byte-compile-warn "third arg to `%s %s' is not a string: %s" + fun var string)) + (byte-compile-form-do-effect + (if (cddr form) ; `value' provided + ;; Quote with `quote' to prevent byte-compiling the body, + ;; which would lead to an inf-loop. + `(funcall '(lambda (,byte-compile-tmp-var) + (,fun ,var ,byte-compile-tmp-var ,@(nthcdr 3 form))) + ,value) + (if (eq fun 'defconst) + ;; This will signal an appropriate error at runtime. + `(eval ',form) + ;; A simple (defvar foo) just returns foo. + `',var))))) (defun byte-compile-autoload (form) (byte-compile-set-symbol-position 'autoload) - (and (byte-compile-constp (nth 1 form)) - (byte-compile-constp (nth 5 form)) + (and (macroexp-const-p (nth 1 form)) + (macroexp-const-p (nth 5 form)) (eval (nth 5 form)) ; macro-p (not (fboundp (eval (nth 1 form)))) (byte-compile-warn @@ -3828,45 +4155,61 @@ that suppresses all warnings during execution of BODY." ;; Lambdas in valid places are handled as special cases by various code. ;; The ones that remain are errors. -(defun byte-compile-lambda-form (form) +(defun byte-compile-lambda-form (_form) (byte-compile-set-symbol-position 'lambda) (error "`lambda' used as function name is invalid")) ;; Compile normally, but deal with warnings for the function being defined. (put 'defalias 'byte-hunk-handler 'byte-compile-file-form-defalias) +;; Used for eieio--defalias as well. (defun byte-compile-file-form-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)))) - (let ((constant - (and (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)))))) - (byte-compile-defalias-warn (nth 1 (nth 1 form))) - (push (cons (nth 1 (nth 1 form)) - (if constant (nth 1 (nth 2 form)) t)) - byte-compile-function-environment))) - ;; We used to just do: (byte-compile-normal-call form) - ;; But it turns out that this fails to optimize the code. - ;; So instead we now do the same as what other byte-hunk-handlers do, - ;; which is to call back byte-compile-file-form and then return nil. - ;; Except that we can't just call byte-compile-file-form since it would - ;; call us right back. - (byte-compile-keep-pending form) - ;; Return nil so the form is not output twice. - nil) - -;; 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) - (let ((calls (assq new byte-compile-unresolved-functions))) - (if calls - (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions))))) + ;; For the compilation itself, we could largely get rid of this hunk-handler, + ;; if it weren't for the fact that we need to figure out when a defalias + ;; defines a macro, so as to add it to byte-compile-macro-environment. + ;; + ;; FIXME: we also use this hunk-handler to implement the function's dynamic + ;; docstring feature. We could actually implement it more elegantly in + ;; byte-compile-lambda so it applies to all lambdas, but the problem is that + ;; the resulting .elc format will not be recognized by make-docfile, so + ;; either we stop using DOC for the docstrings of preloaded elc files (at the + ;; cost of around 24KB on 32bit hosts, double on 64bit hosts) or we need to + ;; build DOC in a more clever way (e.g. handle anonymous elements). + (let ((byte-compile-free-references nil) + (byte-compile-free-assignments nil)) + (pcase form + ;; Decompose `form' into: + ;; - `name' is the name of the defined function. + ;; - `arg' is the expression to which it is defined. + ;; - `rest' is the rest of the arguments. + (`(,_ ',name ,arg . ,rest) + (pcase-let* + ;; `macro' is non-nil if it defines a macro. + ;; `fun' is the function part of `arg' (defaults to `arg'). + (((or (and (or `(cons 'macro ,fun) `'(macro . ,fun)) (let macro t)) + (and (let fun arg) (let macro nil))) + arg) + ;; `lam' is the lambda expression in `fun' (or nil if not + ;; recognized). + ((or `(,(or `quote `function) ,lam) (let lam nil)) + fun) + ;; `arglist' is the list of arguments (or t if not recognized). + ;; `body' is the body of `lam' (or t if not recognized). + ((or `(lambda ,arglist . ,body) + ;; `(closure ,_ ,arglist . ,body) + (and `(internal-make-closure ,arglist . ,_) (let body t)) + (and (let arglist t) (let body t))) + lam)) + (unless (byte-compile-file-form-defmumble + name macro arglist body rest) + (byte-compile-keep-pending form)))) + + ;; We used to just do: (byte-compile-normal-call form) + ;; But it turns out that this fails to optimize the code. + ;; So instead we now do the same as what other byte-hunk-handlers do, + ;; which is to call back byte-compile-file-form and then return nil. + ;; Except that we can't just call byte-compile-file-form since it would + ;; call us right back. + (t (byte-compile-keep-pending form))))) (byte-defop-compiler-1 with-no-warnings byte-compile-no-warnings) (defun byte-compile-no-warnings (form) @@ -3887,6 +4230,25 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-form-make-variable-buffer-local (form) (byte-compile-keep-pending form 'byte-compile-normal-call)) +(byte-defop-compiler-1 add-to-list byte-compile-add-to-list) +(defun byte-compile-add-to-list (form) + ;; FIXME: This could be used for `set' as well, except that it's got + ;; its own opcode, so the final `byte-compile-normal-call' needs to + ;; be replaced with something else. + (pcase form + (`(,fun ',var . ,_) + (byte-compile-check-variable var 'assign) + (if (assq var byte-compile--lexical-environment) + (byte-compile-log-warning + (format "%s cannot use lexical var `%s'" fun var) + nil :error) + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-references)) + (byte-compile-warn "assignment to free variable `%S'" var) + (push var byte-compile-free-references))))) + (byte-compile-normal-call form)) ;;; tags @@ -3903,8 +4265,8 @@ that suppresses all warnings during execution of BODY." (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)))) + (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))) @@ -3916,24 +4278,31 @@ that suppresses all warnings during execution of BODY." (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) (1- byte-compile-depth)))) -(defun byte-compile-out (opcode offset) - (push (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")) - ) - +(defun byte-compile-stack-adjustment (op operand) + "Return the amount by which an operation adjusts the stack. +OP and OPERAND are as passed to `byte-compile-out'." + (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) + ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 + ;; elements, and the push the result, for a total of -OPERAND. + ;; For discardN*, of course, we just pop OPERAND elements. + (- operand) + (or (aref byte-stack+-info (symbol-value op)) + ;; Ops with a nil entry in `byte-stack+-info' are byte-codes + ;; that take OPERAND values off the stack and push a result, for + ;; a total of 1 - OPERAND + (- 1 operand)))) + +(defun byte-compile-out (op &optional operand) + (push (cons op operand) byte-compile-output) + (if (eq op 'byte-return) + ;; This is actually an unnecessary case, because there should be no + ;; more ops behind byte-return. + (setq byte-compile-depth nil) + (setq byte-compile-depth + (+ byte-compile-depth (byte-compile-stack-adjustment op operand))) + (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth)) + ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) + )) ;;; call tree stuff @@ -3992,22 +4361,22 @@ invoked interactively." (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)))))) + (pcase byte-compile-call-tree-sort + (`callers + (lambda (x y) (< (length (nth 1 x)) + (length (nth 1 y))))) + (`calls + (lambda (x y) (< (length (nth 2 x)) + (length (nth 2 y))))) + (`calls+callers + (lambda (x y) (< (+ (length (nth 1 x)) + (length (nth 2 x))) + (+ (length (nth 1 y)) + (length (nth 2 y)))))) + (`name + (lambda (x y) (string< (car x) (car y)))) + (_ (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)) @@ -4115,63 +4484,63 @@ Each file is processed even if an error occurred previously. For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\". If NOFORCE is non-nil, don't recompile a file that seems to be already up-to-date." - ;; command-line-args-left is what is left of the command line (from startup.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 ((bytecomp-error nil)) + (let ((error nil)) (while command-line-args-left (if (file-directory-p (expand-file-name (car command-line-args-left))) ;; Directory as argument. - (let ((bytecomp-files (directory-files (car command-line-args-left))) - bytecomp-source bytecomp-dest) - (dolist (bytecomp-file bytecomp-files) - (if (and (string-match emacs-lisp-file-regexp bytecomp-file) - (not (auto-save-file-name-p bytecomp-file)) - (setq bytecomp-source - (expand-file-name bytecomp-file + (let (source dest) + (dolist (file (directory-files (car command-line-args-left))) + (if (and (string-match emacs-lisp-file-regexp file) + (not (auto-save-file-name-p file)) + (setq source + (expand-file-name file (car command-line-args-left))) - (setq bytecomp-dest (byte-compile-dest-file - bytecomp-source)) - (file-exists-p bytecomp-dest) - (file-newer-than-file-p bytecomp-source bytecomp-dest)) - (if (null (batch-byte-compile-file bytecomp-source)) - (setq bytecomp-error t))))) + (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))))) ;; Specific file argument (if (or (not noforce) - (let* ((bytecomp-source (car command-line-args-left)) - (bytecomp-dest (byte-compile-dest-file bytecomp-source))) - (or (not (file-exists-p bytecomp-dest)) - (file-newer-than-file-p bytecomp-source bytecomp-dest)))) + (let* ((source (car command-line-args-left)) + (dest (byte-compile-dest-file source))) + (or (not (file-exists-p dest)) + (file-newer-than-file-p source dest)))) (if (null (batch-byte-compile-file (car command-line-args-left))) - (setq bytecomp-error t)))) + (setq error t)))) (setq command-line-args-left (cdr command-line-args-left))) - (kill-emacs (if bytecomp-error 1 0)))) - -(defun batch-byte-compile-file (bytecomp-file) - (if debug-on-error - (byte-compile-file bytecomp-file) - (condition-case err - (byte-compile-file bytecomp-file) - (file-error - (message (if (cdr err) - ">>Error occurred processing %s: %s (%s)" - ">>Error occurred processing %s: %s") - bytecomp-file - (get (car err) 'error-message) - (prin1-to-string (cdr err))) - (let ((bytecomp-destfile (byte-compile-dest-file bytecomp-file))) - (if (file-exists-p bytecomp-destfile) - (delete-file bytecomp-destfile))) - nil) - (error - (message (if (cdr err) - ">>Error occurred processing %s: %s (%s)" - ">>Error occurred processing %s: %s") - bytecomp-file - (get (car err) 'error-message) - (prin1-to-string (cdr err))) - nil)))) + (kill-emacs (if error 1 0)))) + +(defun batch-byte-compile-file (file) + (let ((byte-compile-root-dir (or byte-compile-root-dir default-directory))) + (if debug-on-error + (byte-compile-file file) + (condition-case err + (byte-compile-file file) + (file-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))) + (let ((destfile (byte-compile-dest-file file))) + (if (file-exists-p destfile) + (delete-file destfile))) + nil) + (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))))) (defun byte-compile-refresh-preloaded () "Reload any Lisp file that was changed since Emacs was dumped. @@ -4184,7 +4553,14 @@ Use with caution." (setq f (car f)) (if (string-match "elc\\'" f) (setq f (substring f 0 -1))) (when (and (file-readable-p f) - (file-newer-than-file-p f emacs-file)) + (file-newer-than-file-p f emacs-file) + ;; Don't reload the source version of the files below + ;; because that causes subsequent byte-compilation to + ;; be a lot slower and need a higher max-lisp-eval-depth, + ;; so it can cause recompilation to fail. + (not (member (file-name-nondirectory f) + '("pcase.el" "bytecomp.el" "macroexp.el" + "cconv.el" "byte-opt.el")))) (message "Reloading stale %s" (file-name-nondirectory f)) (condition-case nil (load f 'noerror nil 'nosuffix) @@ -4212,6 +4588,16 @@ and corresponding effects." (setq command-line-args-left (cdr command-line-args-left))) (kill-emacs 0)) +;;; Core compiler macros. + +(put 'featurep 'compiler-macro + (lambda (form feature &rest _ignore) + ;; Emacs-21's byte-code doesn't run under XEmacs or SXEmacs anyway, so + ;; we can safely optimize away this test. + (if (member feature '('xemacs 'sxemacs 'emacs)) + (eval form) + form))) + (provide 'byte-compile) (provide 'bytecomp) @@ -4220,6 +4606,8 @@ and corresponding effects." (defvar byte-code-meter) (defun byte-compile-report-ops () + (or (boundp 'byte-metering-on) + (error "You must build Emacs with -DBYTE_CODE_METER to use this")) (with-output-to-temp-buffer "*Meter*" (set-buffer "*Meter*") (let ((i 0) n op off) @@ -4268,5 +4656,4 @@ and corresponding effects." (run-hooks 'bytecomp-load-hook) -;; arch-tag: 9c97b0f0-8745-4571-bfc3-8dceb677292a ;;; bytecomp.el ends here diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el new file mode 100644 index 00000000000..ee84a9f69ba --- /dev/null +++ b/lisp/emacs-lisp/cconv.el @@ -0,0 +1,682 @@ +;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*- + +;; Copyright (C) 2011-2013 Free Software Foundation, Inc. + +;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca> +;; Maintainer: FSF +;; Keywords: lisp +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This takes a piece of Elisp code, and eliminates all free variables from +;; lambda expressions. The user entry points are cconv-closure-convert and +;; cconv-closure-convert-toplevel (for toplevel forms). +;; All macros should be expanded beforehand. +;; +;; Here is a brief explanation how this code works. +;; Firstly, we analyze the tree by calling cconv-analyse-form. +;; This function finds all mutated variables, all functions that are suitable +;; for lambda lifting and all variables captured by closure. It passes the tree +;; once, returning a list of three lists. +;; +;; Then we calculate the intersection of the first and third lists returned by +;; cconv-analyse form to find all mutated variables that are captured by +;; closure. + +;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the +;; tree recursively, lifting lambdas where possible, building closures where it +;; is needed and eliminating mutable variables used in closure. +;; +;; We do following replacements : +;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .) +;; if the function is suitable for lambda lifting (if all calls are known) +;; +;; (lambda (v0 ...) ... fv0 .. fv1 ...) => +;; (internal-make-closure (v0 ...) (fv1 ...) +;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...) +;; +;; If the function has no free variables, we don't do anything. +;; +;; If a variable is mutated (updated by setq), and it is used in a closure +;; we wrap its definition with list: (list val) and we also replace +;; var => (car var) wherever this variable is used, and also +;; (setq var value) => (setcar var value) where it is updated. +;; +;; If defun argument is closure mutable, we letbind it and wrap it's +;; definition with list. +;; (defun foo (... mutable-arg ...) ...) => +;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...)) +;; +;;; Code: + +;; TODO: (not just for cconv but also for the lexbind changes in general) +;; - let (e)debug find the value of lexical variables from the stack. +;; - make eval-region do the eval-sexp-add-defvars dance. +;; - byte-optimize-form should be applied before cconv. +;; OTOH, the warnings emitted by cconv-analyze need to come before optimize +;; since afterwards they can because obnoxious (warnings about an "unused +;; variable" should not be emitted when the variable use has simply been +;; optimized away). +;; - let macros specify that some let-bindings come from the same source, +;; so the unused warning takes all uses into account. +;; - let interactive specs return a function to build the args (to stash into +;; command-history). +;; - canonize code in macro-expand so we don't have to handle (let (var) body) +;; and other oddities. +;; - new byte codes for unwind-protect, catch, and condition-case so that +;; closures aren't needed at all. +;; - inline source code of different binding mode by first compiling it. +;; - a reference to a var that is known statically to always hold a constant +;; should be turned into a byte-constant rather than a byte-stack-ref. +;; Hmm... right, that's called constant propagation and could be done here, +;; but when that constant is a function, we have to be careful to make sure +;; the bytecomp only compiles it once. +;; - Since we know here when a variable is not mutated, we could pass that +;; info to the byte-compiler, e.g. by using a new `immutable-let'. +;; - add tail-calls to bytecode.c and the byte compiler. +;; - call known non-escaping functions with `goto' rather than `call'. +;; - optimize mapcar to a while loop. + +;; (defmacro dlet (binders &rest body) +;; ;; Works in both lexical and non-lexical mode. +;; `(progn +;; ,@(mapcar (lambda (binder) +;; `(defvar ,(if (consp binder) (car binder) binder))) +;; binders) +;; (let ,binders ,@body))) + +;; (defmacro llet (binders &rest body) +;; ;; Only works in lexical-binding mode. +;; `(funcall +;; (lambda ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder)) +;; binders) +;; ,@body) +;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder))) +;; binders))) + +(eval-when-compile (require 'cl-lib)) + +(defconst cconv-liftwhen 6 + "Try to do lambda lifting if the number of arguments + free variables +is less than this number.") +;; List of all the variables that are both captured by a closure +;; and mutated. Each entry in the list takes the form +;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the +;; variable (or is just (VAR) for variables not introduced by let). +(defvar cconv-captured+mutated) + +;; List of candidates for lambda lifting. +;; Each candidate has the form (BINDER . PARENTFORM). A candidate +;; is a variable that is only passed to `funcall' or `apply'. +(defvar cconv-lambda-candidates) + +;; Alist associating to each function body the list of its free variables. +(defvar cconv-freevars-alist) + +;;;###autoload +(defun cconv-closure-convert (form) + "Main entry point for closure conversion. +-- FORM is a piece of Elisp code after macroexpansion. +-- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST + +Returns a form where all lambdas don't have any free variables." + ;; (message "Entering cconv-closure-convert...") + (let ((cconv-freevars-alist '()) + (cconv-lambda-candidates '()) + (cconv-captured+mutated '())) + ;; Analyze form - fill these variables with new information. + (cconv-analyse-form form '()) + (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) + (cconv-convert form nil nil))) ; Env initially empty. + +(defconst cconv--dummy-var (make-symbol "ignored")) + +(defun cconv--set-diff (s1 s2) + "Return elements of set S1 that are not in set S2." + (let ((res '())) + (dolist (x s1) + (unless (memq x s2) (push x res))) + (nreverse res))) + +(defun cconv--set-diff-map (s m) + "Return elements of set S that are not in Dom(M)." + (let ((res '())) + (dolist (x s) + (unless (assq x m) (push x res))) + (nreverse res))) + +(defun cconv--map-diff (m1 m2) + "Return the submap of map M1 that has Dom(M2) removed." + (let ((res '())) + (dolist (x m1) + (unless (assq (car x) m2) (push x res))) + (nreverse res))) + +(defun cconv--map-diff-elem (m x) + "Return the map M minus any mapping for X." + ;; Here we assume that X appears at most once in M. + (let* ((b (assq x m)) + (res (if b (remq b m) m))) + (cl-assert (null (assq x res))) ;; Check the assumption was warranted. + res)) + +(defun cconv--map-diff-set (m s) + "Return the map M minus any mapping for elements of S." + ;; Here we assume that X appears at most once in M. + (let ((res '())) + (dolist (b m) + (unless (memq (car b) s) (push b res))) + (nreverse res))) + +(defun cconv--convert-function (args body env parentform) + (cl-assert (equal body (caar cconv-freevars-alist))) + (let* ((fvs (cdr (pop cconv-freevars-alist))) + (body-new '()) + (letbind '()) + (envector ()) + (i 0) + (new-env ())) + ;; Build the "formal and actual envs" for the closure-converted function. + (dolist (fv fvs) + (let ((exp (or (cdr (assq fv env)) fv))) + (pcase exp + ;; If `fv' is a variable that's wrapped in a cons-cell, + ;; we want to put the cons-cell itself in the closure, + ;; rather than just a copy of its current content. + (`(car ,iexp . ,_) + (push iexp envector) + (push `(,fv . (car (internal-get-closed-var ,i))) new-env)) + (_ + (push exp envector) + (push `(,fv . (internal-get-closed-var ,i)) new-env)))) + (setq i (1+ i))) + (setq envector (nreverse envector)) + (setq new-env (nreverse new-env)) + + (dolist (arg args) + (if (not (member (cons (list arg) parentform) cconv-captured+mutated)) + (if (assq arg new-env) (push `(,arg) new-env)) + (push `(,arg . (car ,arg)) new-env) + (push `(,arg (list ,arg)) letbind))) + + (setq body-new (mapcar (lambda (form) + (cconv-convert form new-env nil)) + body)) + + (when letbind + (let ((special-forms '())) + ;; Keep special forms at the beginning of the body. + (while (or (stringp (car body-new)) ;docstring. + (memq (car-safe (car body-new)) '(interactive declare))) + (push (pop body-new) special-forms)) + (setq body-new + `(,@(nreverse special-forms) (let ,letbind . ,body-new))))) + + (cond + ((null envector) ;if no freevars - do nothing + `(function (lambda ,args . ,body-new))) + (t + `(internal-make-closure + ,args ,envector . ,body-new))))) + +(defun cconv-convert (form env extend) + ;; This function actually rewrites the tree. + "Return FORM with all its lambdas changed so they are closed. +ENV is a lexical environment mapping variables to the expression +used to get its value. This is used for variables that are copied into +closures, moved into cons cells, ... +ENV is a list where each entry takes the shape either: + (VAR . (car EXP)): VAR has been moved into the car of a cons-cell, and EXP + is an expression that evaluates to this cons-cell. + (VAR . (internal-get-closed-var N)): VAR has been copied into the closure + environment's Nth slot. + (VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes + additional arguments ARGs. +EXTEND is a list of variables which might need to be accessed even from places +where they are shadowed, because some part of ENV causes them to be used at +places where they originally did not directly appear." + (cl-assert (not (delq nil (mapcar (lambda (mapping) + (if (eq (cadr mapping) 'apply-partially) + (cconv--set-diff (cdr (cddr mapping)) + extend))) + env)))) + + ;; What's the difference between fvrs and envs? + ;; Suppose that we have the code + ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) + ;; only the first occurrence of fvr should be replaced by + ;; (aref env ...). + ;; So initially envs and fvrs are the same thing, but when we descend to + ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs? + ;; Because in envs the order of variables is important. We use this list + ;; to find the number of a specific variable in the environment vector, + ;; so we never touch it(unless we enter to the other closure). + ;;(if (listp form) (print (car form)) form) + (pcase form + (`(,(and letsym (or `let* `let)) ,binders . ,body) + + ; let and let* special forms + (let ((binders-new '()) + (new-env env) + (new-extend extend)) + + (dolist (binder binders) + (let* ((value nil) + (var (if (not (consp binder)) + (prog1 binder (setq binder (list binder))) + (setq value (cadr binder)) + (car binder))) + (new-val + (cond + ;; Check if var is a candidate for lambda lifting. + ((and (member (cons binder form) cconv-lambda-candidates) + (progn + (cl-assert (and (eq (car value) 'function) + (eq (car (cadr value)) 'lambda))) + (cl-assert (equal (cddr (cadr value)) + (caar cconv-freevars-alist))) + ;; Peek at the freevars to decide whether to λ-lift. + (let* ((fvs (cdr (car cconv-freevars-alist))) + (fun (cadr value)) + (funargs (cadr fun)) + (funcvars (append fvs funargs))) + ; lambda lifting condition + (and fvs (>= cconv-liftwhen (length funcvars)))))) + ; Lift. + (let* ((fvs (cdr (pop cconv-freevars-alist))) + (fun (cadr value)) + (funargs (cadr fun)) + (funcvars (append fvs funargs)) + (funcbody (cddr fun)) + (funcbody-env ())) + (push `(,var . (apply-partially ,var . ,fvs)) new-env) + (dolist (fv fvs) + (cl-pushnew fv new-extend) + (if (and (eq 'car (car-safe (cdr (assq fv env)))) + (not (memq fv funargs))) + (push `(,fv . (car ,fv)) funcbody-env))) + `(function (lambda ,funcvars . + ,(mapcar (lambda (form) + (cconv-convert + form funcbody-env nil)) + funcbody))))) + + ;; Check if it needs to be turned into a "ref-cell". + ((member (cons binder form) cconv-captured+mutated) + ;; Declared variable is mutated and captured. + (push `(,var . (car ,var)) new-env) + `(list ,(cconv-convert value env extend))) + + ;; Normal default case. + (t + (if (assq var new-env) (push `(,var) new-env)) + (cconv-convert value env extend))))) + + ;; The piece of code below letbinds free variables of a λ-lifted + ;; function if they are redefined in this let, example: + ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) + ;; Here we can not pass y as parameter because it is redefined. + ;; So we add a (closed-y y) declaration. We do that even if the + ;; function is not used inside this let(*). The reason why we + ;; ignore this case is that we can't "look forward" to see if the + ;; function is called there or not. To treat this case better we'd + ;; need to traverse the tree one more time to collect this data, and + ;; I think that it's not worth it. + (when (memq var new-extend) + (let ((closedsym + (make-symbol (concat "closed-" (symbol-name var))))) + (setq new-env + (mapcar (lambda (mapping) + (if (not (eq (cadr mapping) 'apply-partially)) + mapping + (cl-assert (eq (car mapping) (nth 2 mapping))) + `(,(car mapping) + apply-partially + ,(car mapping) + ,@(mapcar (lambda (arg) + (if (eq var arg) + closedsym arg)) + (nthcdr 3 mapping))))) + new-env)) + (setq new-extend (remq var new-extend)) + (push closedsym new-extend) + (push `(,closedsym ,var) binders-new))) + + ;; We push the element after redefined free variables are + ;; processed. This is important to avoid the bug when free + ;; variable and the function have the same name. + (push (list var new-val) binders-new) + + (when (eq letsym 'let*) + (setq env new-env) + (setq extend new-extend)) + )) ; end of dolist over binders + + `(,letsym ,(nreverse binders-new) + . ,(mapcar (lambda (form) + (cconv-convert + form new-env new-extend)) + body)))) + ;end of let let* forms + + ; first element is lambda expression + (`(,(and `(lambda . ,_) fun) . ,args) + ;; FIXME: it's silly to create a closure just to call it. + ;; Running byte-optimize-form earlier will resolve this. + `(funcall + ,(cconv-convert `(function ,fun) env extend) + ,@(mapcar (lambda (form) + (cconv-convert form env extend)) + args))) + + (`(cond . ,cond-forms) ; cond special form + `(cond . ,(mapcar (lambda (branch) + (mapcar (lambda (form) + (cconv-convert form env extend)) + branch)) + cond-forms))) + + (`(function (lambda ,args . ,body) . ,_) + (cconv--convert-function args body env form)) + + (`(internal-make-closure . ,_) + (byte-compile-report-error + "Internal error in compiler: cconv called twice?")) + + (`(quote . ,_) form) + (`(function . ,_) form) + + ;defconst, defvar + (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,forms) + `(,sym ,definedsymbol + . ,(mapcar (lambda (form) (cconv-convert form env extend)) + forms))) + + ;condition-case + (`(condition-case ,var ,protected-form . ,handlers) + (let ((newform (cconv--convert-function + () (list protected-form) env form))) + `(condition-case :fun-body ,newform + ,@(mapcar (lambda (handler) + (list (car handler) + (cconv--convert-function + (list (or var cconv--dummy-var)) + (cdr handler) env form))) + handlers)))) + + (`(,(and head (or `catch `unwind-protect)) ,form . ,body) + `(,head ,(cconv-convert form env extend) + :fun-body ,(cconv--convert-function () body env form))) + + (`(track-mouse . ,body) + `(track-mouse + :fun-body ,(cconv--convert-function () body env form))) + + (`(setq . ,forms) ; setq special form + (let ((prognlist ())) + (while forms + (let* ((sym (pop forms)) + (sym-new (or (cdr (assq sym env)) sym)) + (value (cconv-convert (pop forms) env extend))) + (push (pcase sym-new + ((pred symbolp) `(setq ,sym-new ,value)) + (`(car ,iexp) `(setcar ,iexp ,value)) + ;; This "should never happen", but for variables which are + ;; mutated+captured+unused, we may end up trying to `setq' + ;; on a closed-over variable, so just drop the setq. + (_ ;; (byte-compile-report-error + ;; (format "Internal error in cconv of (setq %s ..)" + ;; sym-new)) + value)) + prognlist))) + (if (cdr prognlist) + `(progn . ,(nreverse prognlist)) + (car prognlist)))) + + (`(,(and (or `funcall `apply) callsym) ,fun . ,args) + ;; These are not special forms but we treat them separately for the needs + ;; of lambda lifting. + (let ((mapping (cdr (assq fun env)))) + (pcase mapping + (`(apply-partially ,_ . ,(and fvs `(,_ . ,_))) + (cl-assert (eq (cadr mapping) fun)) + `(,callsym ,fun + ,@(mapcar (lambda (fv) + (let ((exp (or (cdr (assq fv env)) fv))) + (pcase exp + (`(car ,iexp . ,_) iexp) + (_ exp)))) + fvs) + ,@(mapcar (lambda (arg) + (cconv-convert arg env extend)) + args))) + (_ `(,callsym ,@(mapcar (lambda (arg) + (cconv-convert arg env extend)) + (cons fun args))))))) + + (`(interactive . ,forms) + `(interactive . ,(mapcar (lambda (form) + (cconv-convert form nil nil)) + forms))) + + (`(declare . ,_) form) ;The args don't contain code. + + (`(,func . ,forms) + ;; First element is function or whatever function-like forms are: or, and, + ;; if, progn, prog1, prog2, while, until + `(,func . ,(mapcar (lambda (form) + (cconv-convert form env extend)) + forms))) + + (_ (or (cdr (assq form env)) form)))) + +(unless (fboundp 'byte-compile-not-lexical-var-p) + ;; Only used to test the code in non-lexbind Emacs. + (defalias 'byte-compile-not-lexical-var-p 'boundp)) + +(defun cconv--analyse-use (vardata form varkind) + "Analyze the use of a variable. +VARDATA should be (BINDER READ MUTATED CAPTURED CALLED). +VARKIND is the name of the kind of variable. +FORM is the parent form that binds this var." + ;; use = `(,binder ,read ,mutated ,captured ,called) + (pcase vardata + (`(,_ nil nil nil nil) nil) + (`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_) + ,_ ,_ ,_ ,_) + (byte-compile-log-warning + (format "%s `%S' not left unused" varkind var)))) + (pcase vardata + (`((,var . ,_) nil ,_ ,_ nil) + ;; FIXME: This gives warnings in the wrong order, with imprecise line + ;; numbers and without function name info. + (unless (or ;; Uninterned symbols typically come from macro-expansion, so + ;; it is often non-trivial for the programmer to avoid such + ;; unused vars. + (not (intern-soft var)) + (eq ?_ (aref (symbol-name var) 0)) + ;; As a special exception, ignore "ignore". + (eq var 'ignored)) + (byte-compile-log-warning (format "Unused lexical %s `%S'" + varkind var)))) + ;; If it's unused, there's no point converting it into a cons-cell, even if + ;; it's captured and mutated. + (`(,binder ,_ t t ,_) + (push (cons binder form) cconv-captured+mutated)) + (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) + (push (cons binder form) cconv-lambda-candidates)))) + +(defun cconv--analyse-function (args body env parentform) + (let* ((newvars nil) + (freevars (list body)) + ;; We analyze the body within a new environment where all uses are + ;; nil, so we can distinguish uses within that function from uses + ;; outside of it. + (envcopy + (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env)) + (newenv envcopy)) + ;; Push it before recursing, so cconv-freevars-alist contains entries in + ;; the order they'll be used by closure-convert-rec. + (push freevars cconv-freevars-alist) + (dolist (arg args) + (cond + ((byte-compile-not-lexical-var-p arg) + (byte-compile-log-warning + (format "Argument %S is not a lexical variable" arg))) + ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... + (t (let ((varstruct (list arg nil nil nil nil))) + (push (cons (list arg) (cdr varstruct)) newvars) + (push varstruct newenv))))) + (dolist (form body) ;Analyze body forms. + (cconv-analyse-form form newenv)) + ;; Summarize resulting data about arguments. + (dolist (vardata newvars) + (cconv--analyse-use vardata parentform "argument")) + ;; Transfer uses collected in `envcopy' (via `newenv') back to `env'; + ;; and compute free variables. + (while env + (cl-assert (and envcopy (eq (caar env) (caar envcopy)))) + (let ((free nil) + (x (cdr (car env))) + (y (cdr (car envcopy)))) + (while x + (when (car y) (setcar x t) (setq free t)) + (setq x (cdr x) y (cdr y))) + (when free + (push (caar env) (cdr freevars)) + (setf (nth 3 (car env)) t)) + (setq env (cdr env) envcopy (cdr envcopy)))))) + +(defun cconv-analyse-form (form env) + "Find mutated variables and variables captured by closure. +Analyze lambdas if they are suitable for lambda lifting. +- FORM is a piece of Elisp code after macroexpansion. +- ENV is an alist mapping each enclosing lexical variable to its info. + I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)). +This function does not return anything but instead fills the +`cconv-captured+mutated' and `cconv-lambda-candidates' variables +and updates the data stored in ENV." + (pcase form + ; let special form + (`(,(and (or `let* `let) letsym) ,binders . ,body-forms) + + (let ((orig-env env) + (newvars nil) + (var nil) + (value nil)) + (dolist (binder binders) + (if (not (consp binder)) + (progn + (setq var binder) ; treat the form (let (x) ...) well + (setq binder (list binder)) + (setq value nil)) + (setq var (car binder)) + (setq value (cadr binder)) + + (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) + + (unless (byte-compile-not-lexical-var-p var) + (let ((varstruct (list var nil nil nil nil))) + (push (cons binder (cdr varstruct)) newvars) + (push varstruct env)))) + + (dolist (form body-forms) ; Analyze body forms. + (cconv-analyse-form form env)) + + (dolist (vardata newvars) + (cconv--analyse-use vardata form "variable")))) + + (`(function (lambda ,vrs . ,body-forms)) + (cconv--analyse-function vrs body-forms env form)) + + (`(setq . ,forms) + ;; If a local variable (member of env) is modified by setq then + ;; it is a mutated variable. + (while forms + (let ((v (assq (car forms) env))) ; v = non nil if visible + (when v (setf (nth 2 v) t))) + (cconv-analyse-form (cadr forms) env) + (setq forms (cddr forms)))) + + (`((lambda . ,_) . ,_) ; First element is lambda expression. + (byte-compile-log-warning + "Use of deprecated ((lambda ...) ...) form" t :warning) + (dolist (exp `((function ,(car form)) . ,(cdr form))) + (cconv-analyse-form exp env))) + + (`(cond . ,cond-forms) ; cond special form + (dolist (forms cond-forms) + (dolist (form forms) (cconv-analyse-form form env)))) + + (`(quote . ,_) nil) ; quote form + (`(function . ,_) nil) ; same as quote + + (`(condition-case ,var ,protected-form . ,handlers) + ;; FIXME: The bytecode for condition-case forces us to wrap the + ;; form and handlers in closures (for handlers, it's understandable + ;; but not for the protected form). + (cconv--analyse-function () (list protected-form) env form) + (dolist (handler handlers) + (cconv--analyse-function (if var (list var)) (cdr handler) env form))) + + ;; FIXME: The bytecode for catch forces us to wrap the body. + (`(,(or `catch `unwind-protect) ,form . ,body) + (cconv-analyse-form form env) + (cconv--analyse-function () body env form)) + + ;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body. + ;; `track-mouse' really should be made into a macro. + (`(track-mouse . ,body) + (cconv--analyse-function () body env form)) + + (`(,(or `defconst `defvar) ,var ,value . ,_) + (push var byte-compile-bound-variables) + (cconv-analyse-form value env)) + + (`(,(or `funcall `apply) ,fun . ,args) + ;; Here we ignore fun because funcall and apply are the only two + ;; functions where we can pass a candidate for lambda lifting as + ;; argument. So, if we see fun elsewhere, we'll delete it from + ;; lambda candidate list. + (let ((fdata (and (symbolp fun) (assq fun env)))) + (if fdata + (setf (nth 4 fdata) t) + (cconv-analyse-form fun env))) + (dolist (form args) (cconv-analyse-form form env))) + + (`(interactive . ,forms) + ;; These appear within the function body but they don't have access + ;; to the function's arguments. + ;; We could extend this to allow interactive specs to refer to + ;; variables in the function's enclosing environment, but it doesn't + ;; seem worth the trouble. + (dolist (form forms) (cconv-analyse-form form nil))) + + (`(declare . ,_) nil) ;The args don't contain code. + + (`(,_ . ,body-forms) ; First element is a function or whatever. + (dolist (form body-forms) (cconv-analyse-form form env))) + + ((pred symbolp) + (let ((dv (assq form env))) ; dv = declared and visible + (when dv + (setf (nth 1 dv) t)))))) + +(provide 'cconv) +;;; cconv.el ends here diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 9c2808a0764..a259985df99 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -1,7 +1,7 @@ -;;; chart.el --- Draw charts (bar charts, etc) +;;; chart.el --- Draw charts (bar charts, etc) -*- lexical-binding: t -*- -;; Copyright (C) 1996, 1998, 1999, 2001, 2004, 2005, 2007, 2008, 2009, 2010, 2011, 2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2013 Free +;; Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 @@ -62,21 +62,13 @@ (require 'eieio) ;;; Code: -(defvar chart-map nil "Keymap used in chart mode.") -(if chart-map - () - (setq chart-map (make-sparse-keymap)) - ) +(define-obsolete-variable-alias 'chart-map 'chart-mode-map "24.1") +(defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.") (defvar chart-local-object nil "Local variable containing the locally displayed chart object.") (make-variable-buffer-local 'chart-local-object) -(defvar chart-face-list nil - "Faces used to colorize charts. -List is limited currently, which is ok since you really can't display -too much in text characters anyways.") - (defvar chart-face-color-list '("red" "green" "blue" "cyan" "yellow" "purple") "Colors to use when generating `chart-face-list'. @@ -90,45 +82,46 @@ Colors will be the background color.") Useful if new Emacs is used on B&W display.") (defcustom chart-face-use-pixmaps nil - "*Non-nil to use fancy pixmaps in the background of chart face colors." + "Non-nil to use fancy pixmaps in the background of chart face colors." :group 'eieio :type 'boolean) -(if (and (if (fboundp 'display-color-p) - (display-color-p) - window-system) - (not chart-face-list)) - (let ((cl chart-face-color-list) - (pl chart-face-pixmap-list) - nf) - (while cl - (setq nf (make-face (intern (concat "chart-" (car cl) "-" (car pl))))) - (if (condition-case nil - (> (x-display-color-cells) 4) - (error t)) - (set-face-background nf (car cl)) - (set-face-background nf "white")) - (set-face-foreground nf "black") - (if (and chart-face-use-pixmaps - pl - (fboundp 'set-face-background-pixmap)) - (condition-case nil - (set-face-background-pixmap nf (car pl)) - (error (message "Cannot set background pixmap %s" (car pl))))) - (setq chart-face-list (cons nf chart-face-list)) - (setq cl (cdr cl) - pl (cdr pl))))) - -(defun chart-mode () +(defvar chart-face-list + (if (if (fboundp 'display-color-p) + (display-color-p) + window-system) + (let ((cl chart-face-color-list) + (pl chart-face-pixmap-list) + (faces ()) + nf) + (while cl + (setq nf (make-face + (intern (concat "chart-" (car cl) "-" (car pl))))) + (set-face-background nf (if (condition-case nil + (> (x-display-color-cells) 4) + (error t)) + (car cl) + "white")) + (set-face-foreground nf "black") + (if (and chart-face-use-pixmaps + pl + (fboundp 'set-face-background-pixmap)) + (condition-case nil + (set-face-background-pixmap nf (car pl)) + (error (message "Cannot set background pixmap %s" (car pl))))) + (push nf faces) + (setq cl (cdr cl) + pl (cdr pl))) + faces)) + "Faces used to colorize charts. +List is limited currently, which is ok since you really can't display +too much in text characters anyways.") + +(define-derived-mode chart-mode fundamental-mode "CHART" "Define a mode in Emacs for displaying a chart." - (kill-all-local-variables) - (use-local-map chart-map) - (setq major-mode 'chart-mode - mode-name "CHART") (buffer-disable-undo) (set (make-local-variable 'font-lock-global-modes) nil) - (font-lock-mode -1) - (run-hooks 'chart-mode-hook) + (font-lock-mode -1) ;Isn't it off already? --Stef ) (defun chart-new-buffer (obj) @@ -163,7 +156,7 @@ Returns the newly created buffer." ) "Superclass for all charts to be displayed in an Emacs buffer.") -(defmethod initialize-instance :AFTER ((obj chart) &rest fields) +(defmethod initialize-instance :AFTER ((obj chart) &rest _fields) "Initialize the chart OBJ being created with FIELDS. Make sure the width/height is correct." (oset obj x-width (- (window-width) 10)) @@ -176,7 +169,7 @@ Make sure the width/height is correct." :initform t) (name-face :initarg :name-face :initform 'bold) - (labels-face :initarg :lables-face + (labels-face :initarg :labels-face :initform 'italic) (chart :initarg :chart :initform nil) @@ -283,7 +276,7 @@ START and END represent the boundary." (float (- (cdr range) (car range))))))))) ) -(defmethod chart-axis-draw ((a chart-axis-range) &optional dir margin zone start end) +(defmethod chart-axis-draw ((a chart-axis-range) &optional dir margin zone _start _end) "Draw axis information based upon a range to be spread along the edge. A is the chart to draw. DIR is the direction. MARGIN, ZONE, START, and END specify restrictions in chart space." @@ -336,7 +329,7 @@ Automatically compensates for direction." (+ m -1 (round (* lpn (+ 1.0 (float n)))))) )) -(defmethod chart-axis-draw ((a chart-axis-names) &optional dir margin zone start end) +(defmethod chart-axis-draw ((a chart-axis-names) &optional dir margin zone _start _end) "Draw axis information based upon A range to be spread along the edge. Optional argument DIR is the direction of the chart. Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing." @@ -529,9 +522,9 @@ cons cells of the form (NAME . NUM). See `sort' for more details." (defun chart-zap-chars (n) "Zap up to N chars without deleting EOLs." (if (not (eobp)) - (if (< n (- (save-excursion (end-of-line) (point)) (point))) + (if (< n (- (point-at-eol) (point))) (delete-char n) - (delete-region (point) (save-excursion (end-of-line) (point)))))) + (delete-region (point) (point-at-eol))))) (defun chart-display-label (label dir zone start end &optional face) "Display LABEL in direction DIR in column/row ZONE between START and END. @@ -641,12 +634,12 @@ SORT-PRED if desired." (setq extlst (cons s extlst) cntlst (cons 1 cntlst))))) (setq flst (cdr flst))) - ;; Lets create the chart! + ;; Let's create the chart! (chart-bar-quickie 'vertical "Files Extension Distribution" extlst "File Extensions" cntlst "# of occurrences" 10 - '(lambda (a b) (> (cdr a) (cdr b)))) + (lambda (a b) (> (cdr a) (cdr b)))) )) (defun chart-space-usage (d) @@ -676,34 +669,20 @@ SORT-PRED if desired." nmlst "File Name" cntlst "File Size" 10 - '(lambda (a b) (> (cdr a) (cdr b)))) + (lambda (a b) (> (cdr a) (cdr b)))) )) (defun chart-emacs-storage () "Chart the current storage requirements of Emacs." (interactive) - (let* ((data (garbage-collect)) - (names '("strings/2" "vectors" - "conses" "free cons" - "syms" "free syms" - "markers" "free mark" - ;; "floats" "free flt" - )) - (nums (list (/ (nth 3 data) 2) - (nth 4 data) - (car (car data)) ; conses - (cdr (car data)) - (car (nth 1 data)) ; syms - (cdr (nth 1 data)) - (car (nth 2 data)) ; markers - (cdr (nth 2 data)) - ;(car (nth 5 data)) ; floats are Emacs only - ;(cdr (nth 5 data)) - ))) - ;; Lets create the chart! + (let* ((data (garbage-collect))) + ;; Let's create the chart! (chart-bar-quickie 'vertical "Emacs Runtime Storage Usage" - names "Storage Items" - nums "Objects"))) + (mapcar (lambda (x) (symbol-name (car x))) data) + "Storage Items" + (mapcar (lambda (x) (* (nth 1 x) (nth 2 x))) + data) + "Bytes"))) (defun chart-emacs-lists () "Chart out the size of various important lists." @@ -717,7 +696,7 @@ SORT-PRED if desired." (if (fboundp 'x-display-list) (setq names (append names '("x-displays")) nums (append nums (list (length (x-display-list)))))) - ;; Lets create the chart! + ;; Let's create the chart! (chart-bar-quickie 'vertical "Emacs List Size Chart" names "Various Lists" nums "Objects"))) @@ -744,11 +723,10 @@ SORT-PRED if desired." nmlst "User Names" cntlst "# of occurrences" 10 - '(lambda (a b) (> (cdr a) (cdr b)))) + (lambda (a b) (> (cdr a) (cdr b)))) )) (provide 'chart) -;; arch-tag: 43847e44-5b45-465e-adc9-e505490a6b59 ;;; chart.el ends here diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index c4370e7ee8c..367db5240c9 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -1,6 +1,6 @@ ;;; check-declare.el --- Check declare-function statements -;; Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2007-2013 Free Software Foundation, Inc. ;; Author: Glenn Morris <rgm@gnu.org> ;; Keywords: lisp, tools, maint @@ -28,7 +28,7 @@ ;; checks that all such statements in a file or directory are accurate. ;; The entry points are `check-declare-file' and `check-declare-directory'. -;; For more information, see Info node `elisp(Declaring Functions)'. +;; For more information, see Info node `(elisp)Declaring Functions'. ;;; TODO: @@ -88,9 +88,11 @@ don't know how to recognize (e.g. some macros)." ;; FIXME we could theoretically be inside a string. (while (re-search-forward "^[ \t]*\\((declare-function\\)[ \t\n]" nil t) (goto-char (match-beginning 1)) - (if (and (setq form (ignore-errors (read (current-buffer))) - len (length form)) - (> len 2) (< len 6) + (if (and (setq form (ignore-errors (read (current-buffer)))) + ;; Exclude element of byte-compile-initial-macro-environment. + (or (listp (cdr form)) (setq form nil)) + (> (setq len (length form)) 2) + (< len 6) (symbolp (setq fn (cadr form))) (setq fn (symbol-name fn)) ; later we use as a search string (stringp (setq fnfile (nth 2 form))) @@ -104,7 +106,7 @@ don't know how to recognize (e.g. some macros)." (symbolp (setq fileonly (nth 4 form)))) (setq alist (cons (list fnfile fn arglist fileonly) alist)) ;; FIXME make this more noticeable. - (message "Malformed declaration for `%s'" (cadr form))))) + (if form (message "Malformed declaration for `%s'" (cadr form)))))) (message "%sdone" m) alist)) @@ -314,5 +316,4 @@ Returns non-nil if any false statements are found." (provide 'check-declare) -;; arch-tag: a4d6cdc4-deb7-4502-b327-0e4ef3d82d96 ;;; check-declare.el ends here. diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 33afaf6add3..b154e722707 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1,7 +1,6 @@ ;;; checkdoc.el --- check documentation strings for style requirements -;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1997-1998, 2001-2013 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.6.2 @@ -39,8 +38,7 @@ ;; or [menu-bar emacs-lisp eval-buffer]. Additional key-bindings ;; are also provided under C-c ? KEY ;; (require 'checkdoc) -;; (add-hook 'emacs-lisp-mode-hook -;; '(lambda () (checkdoc-minor-mode 1))) +;; (add-hook 'emacs-lisp-mode-hook 'checkdoc-minor-mode) ;; ;; Using `checkdoc': ;; @@ -126,7 +124,7 @@ ;; Adding your own checks: ;; ;; You can experiment with adding your own checks by setting the -;; hooks `checkdoc-style-hooks' and `checkdoc-comment-style-hooks'. +;; hooks `checkdoc-style-functions' and `checkdoc-comment-style-functions'. ;; Return a string which is the error you wish to report. The cursor ;; position should be preserved. ;; @@ -201,9 +199,9 @@ without asking, and complex changes are made by asking the user first. The value `never' is the same as nil, never ask or change anything." :group 'checkdoc :type '(choice (const automatic) - (const query) - (const never) - (other :tag "semiautomatic" semiautomatic))) + (const query) + (const never) + (other :tag "semiautomatic" semiautomatic))) (defcustom checkdoc-bouncy-flag t "Non-nil means to \"bounce\" to auto-fix locations. @@ -250,10 +248,10 @@ system. Possible values are: t - Always spell-check" :group 'checkdoc :type '(choice (const nil) - (const defun) - (const buffer) - (const interactive) - (const t))) + (const defun) + (const buffer) + (const interactive) + (const t))) (defvar checkdoc-ispell-lisp-words '("alist" "emacs" "etags" "keymap" "paren" "regexp" "sexp" "xemacs") @@ -276,17 +274,21 @@ made in the style guide relating to order." :type 'boolean) ;;;###autoload(put 'checkdoc-arguments-in-order-flag 'safe-local-variable 'booleanp) -(defvar checkdoc-style-hooks nil - "Hooks called after the standard style check is completed. -All hooks must return nil or a string representing the error found. +(define-obsolete-variable-alias 'checkdoc-style-hooks + 'checkdoc-style-functions "24.3") +(defvar checkdoc-style-functions nil + "Hook run after the standard style check is completed. +All functions must return nil or a string representing the error found. Useful for adding new user implemented commands. Each hook is called with two parameters, (DEFUNINFO ENDPOINT). DEFUNINFO is the return value of `checkdoc-defun-info'. ENDPOINT is the location of end of the documentation string.") -(defvar checkdoc-comment-style-hooks nil - "Hooks called after the standard comment style check is completed. +(define-obsolete-variable-alias 'checkdoc-comment-style-hooks + 'checkdoc-comment-style-functions "24.3") +(defvar checkdoc-comment-style-functions nil + "Hook run after the standard comment style check is completed. Must return nil if no errors are found, or a string describing the problem discovered. This is useful for adding additional checks.") @@ -429,19 +431,15 @@ and experimental check. Do not modify this list without setting the value of `checkdoc-common-verbs-regexp' to nil which cause it to be re-created.") -(defvar checkdoc-syntax-table nil +(defvar checkdoc-syntax-table + (let ((st (make-syntax-table emacs-lisp-mode-syntax-table))) + ;; When dealing with syntax in doc strings, make sure that - are + ;; encompassed in words so we can use cheap \\> to get the end of a symbol, + ;; not the end of a word in a conglomerate. + (modify-syntax-entry ?- "w" st) + st) "Syntax table used by checkdoc in document strings.") -(if checkdoc-syntax-table - nil - (setq checkdoc-syntax-table (copy-syntax-table emacs-lisp-mode-syntax-table)) - ;; When dealing with syntax in doc strings, make sure that - are encompassed - ;; in words so we can use cheap \\> to get the end of a symbol, not the - ;; end of a word in a conglomerate. - (modify-syntax-entry ?- "w" checkdoc-syntax-table) - ) - - ;;; Compatibility ;; (defalias 'checkdoc-make-overlay @@ -515,12 +513,11 @@ CHECK is a list of four strings stating the current status of each test; the nth string describes the status of the nth test." (let (temp-buffer-setup-hook) (with-output-to-temp-buffer "*Checkdoc Status*" - (princ-list - "Buffer comments and tags: " (nth 0 check) "\n" - "Documentation style: " (nth 1 check) "\n" - "Message/Query text style: " (nth 2 check) "\n" - "Unwanted Spaces: " (nth 3 check) - ))) + (mapc #'princ + (list "Buffer comments and tags: " (nth 0 check) + "\nDocumentation style: " (nth 1 check) + "\nMessage/Query text style: " (nth 2 check) + "\nUnwanted Spaces: " (nth 3 check))))) (shrink-window-if-larger-than-buffer (get-buffer-window "*Checkdoc Status*")) (message nil) @@ -623,7 +620,7 @@ style." (recenter (/ (- (window-height) l) 2)))) (recenter)) (message "%s (C-h,%se,n,p,q)" (checkdoc-error-text - (car (car err-list))) + (car (car err-list))) (if (checkdoc-error-unfixable (car (car err-list))) "" "f,")) (save-excursion @@ -713,20 +710,21 @@ style." (delete-window (get-buffer-window "*Checkdoc Help*")) (kill-buffer "*Checkdoc Help*")) (with-output-to-temp-buffer "*Checkdoc Help*" - (princ-list - "Checkdoc Keyboard Summary:\n" - (if (checkdoc-error-unfixable (car (car err-list))) - "" - (concat - "f, y - auto Fix this warning without asking (if\ + (with-current-buffer standard-output + (insert + "Checkdoc Keyboard Summary:\n" + (if (checkdoc-error-unfixable (car (car err-list))) + "" + (concat + "f, y - auto Fix this warning without asking (if\ available.)\n" - " Very complex operations will still query.\n") - ) - "e - Enter recursive Edit. Press C-M-c to exit.\n" - "SPC, n - skip to the Next error.\n" - "DEL, p - skip to the Previous error.\n" - "q - Quit checkdoc.\n" - "C-h - Toggle this help buffer.")) + " Very complex operations will still query.\n") + ) + "e - Enter recursive Edit. Press C-M-c to exit.\n" + "SPC, n - skip to the Next error.\n" + "DEL, p - skip to the Previous error.\n" + "q - Quit checkdoc.\n" + "C-h - Toggle this help buffer."))) (shrink-window-if-larger-than-buffer (get-buffer-window "*Checkdoc Help*")))))) (if cdo (checkdoc-delete-overlay cdo))))) @@ -826,9 +824,9 @@ assumes that the cursor is already positioned to perform the fix." "Enter recursive edit to permit a user to fix some error checkdoc has found. MSG is the error that was found, which is displayed in a help buffer." (with-output-to-temp-buffer "*Checkdoc Help*" - (princ-list - "Error message:\n " msg - "\n\nEdit to fix this problem, and press C-M-c to continue.")) + (mapc #'princ + (list "Error message:\n " msg + "\n\nEdit to fix this problem, and press C-M-c to continue."))) (shrink-window-if-larger-than-buffer (get-buffer-window "*Checkdoc Help*")) (message "When you're done editing press C-M-c to continue.") @@ -922,7 +920,7 @@ is the starting location. If this is nil, `point-min' is used instead." (progn (goto-char wrong) (if (not take-notes) - (error "%s" (checkdoc-error-text msg))))) + (user-error "%s" (checkdoc-error-text msg))))) (checkdoc-show-diagnostics) (if (called-interactively-p 'interactive) (message "No style warnings.")))) @@ -947,15 +945,15 @@ if there is one." (interactive "P") (if take-notes (checkdoc-start-section "checkdoc-comments")) (if (not buffer-file-name) - (error "Can only check comments for a file buffer")) + (error "Can only check comments for a file buffer")) (let* ((checkdoc-spellcheck-documentation-flag (car (memq checkdoc-spellcheck-documentation-flag '(buffer t)))) (checkdoc-autofix-flag (if take-notes 'never checkdoc-autofix-flag)) (e (checkdoc-file-comments-engine)) - (checkdoc-generate-compile-warnings-flag - (or take-notes checkdoc-generate-compile-warnings-flag))) - (if e (error "%s" (checkdoc-error-text e))) + (checkdoc-generate-compile-warnings-flag + (or take-notes checkdoc-generate-compile-warnings-flag))) + (if e (user-error "%s" (checkdoc-error-text e))) (checkdoc-show-diagnostics) e)) @@ -970,8 +968,8 @@ Optional argument INTERACT permits more interactive fixing." (if take-notes (checkdoc-start-section "checkdoc-rogue-spaces")) (let* ((checkdoc-autofix-flag (if take-notes 'never checkdoc-autofix-flag)) (e (checkdoc-rogue-space-check-engine nil nil interact)) - (checkdoc-generate-compile-warnings-flag - (or take-notes checkdoc-generate-compile-warnings-flag))) + (checkdoc-generate-compile-warnings-flag + (or take-notes checkdoc-generate-compile-warnings-flag))) (if (not (called-interactively-p 'interactive)) e (if e @@ -993,7 +991,7 @@ Optional argument TAKE-NOTES causes all errors to be logged." (if (not (called-interactively-p 'interactive)) e (if e - (error "%s" (checkdoc-error-text e)) + (user-error "%s" (checkdoc-error-text e)) (checkdoc-show-diagnostics))) (goto-char p)) (if (called-interactively-p 'interactive) @@ -1033,19 +1031,14 @@ space at the end of each line." (car (memq checkdoc-spellcheck-documentation-flag '(defun t)))) (beg (save-excursion (beginning-of-defun) (point))) - (end (save-excursion (end-of-defun) (point))) - (msg (checkdoc-this-string-valid))) - (if msg (if no-error - (message "%s" (checkdoc-error-text msg)) - (error "%s" (checkdoc-error-text msg))) - (setq msg (checkdoc-message-text-search beg end)) - (if msg (if no-error - (message "%s" (checkdoc-error-text msg)) - (error "%s" (checkdoc-error-text msg))) - (setq msg (checkdoc-rogue-space-check-engine beg end)) - (if msg (if no-error - (message "%s" (checkdoc-error-text msg)) - (error "%s" (checkdoc-error-text msg)))))) + (end (save-excursion (end-of-defun) (point)))) + (dolist (fun (list #'checkdoc-this-string-valid + (lambda () (checkdoc-message-text-search beg end)) + (lambda () (checkdoc-rogue-space-check-engine beg end)))) + (let ((msg (funcall fun))) + (if msg (if no-error + (message "%s" (checkdoc-error-text msg)) + (user-error "%s" (checkdoc-error-text msg)))))) (if (called-interactively-p 'interactive) (message "Checkdoc: done.")))))) @@ -1207,48 +1200,46 @@ generating a buffered list of errors." map) "Keymap used to override evaluation key-bindings for documentation checking.") -(define-obsolete-variable-alias 'checkdoc-minor-keymap - 'checkdoc-minor-mode-map "21.1") - ;; Add in a menubar with easy-menu (easy-menu-define - nil checkdoc-minor-mode-map "Checkdoc Minor Mode Menu" - '("CheckDoc" - ["Interactive Buffer Style Check" checkdoc t] - ["Interactive Buffer Style and Spelling Check" checkdoc-ispell t] - ["Check Buffer" checkdoc-current-buffer t] - ["Check and Spell Buffer" checkdoc-ispell-current-buffer t] - "---" - ["Interactive Style Check" checkdoc-interactive t] - ["Interactive Style and Spelling Check" checkdoc-ispell-interactive t] - ["Find First Style Error" checkdoc-start t] - ["Find First Style or Spelling Error" checkdoc-ispell-start t] - ["Next Style Error" checkdoc-continue t] - ["Next Style or Spelling Error" checkdoc-ispell-continue t] - ["Interactive Message Text Style Check" checkdoc-message-interactive t] - ["Interactive Message Text Style and Spelling Check" - checkdoc-ispell-message-interactive t] - ["Check Message Text" checkdoc-message-text t] - ["Check and Spell Message Text" checkdoc-ispell-message-text t] - ["Check Comment Style" checkdoc-comments buffer-file-name] - ["Check Comment Style and Spelling" checkdoc-ispell-comments - buffer-file-name] - ["Check for Rogue Spaces" checkdoc-rogue-spaces t] - "---" - ["Check Defun" checkdoc-defun t] - ["Check and Spell Defun" checkdoc-ispell-defun t] - ["Check and Evaluate Defun" checkdoc-eval-defun t] - ["Check and Evaluate Buffer" checkdoc-eval-current-buffer t] - )) + nil checkdoc-minor-mode-map "Checkdoc Minor Mode Menu" + '("CheckDoc" + ["Interactive Buffer Style Check" checkdoc t] + ["Interactive Buffer Style and Spelling Check" checkdoc-ispell t] + ["Check Buffer" checkdoc-current-buffer t] + ["Check and Spell Buffer" checkdoc-ispell-current-buffer t] + "---" + ["Interactive Style Check" checkdoc-interactive t] + ["Interactive Style and Spelling Check" checkdoc-ispell-interactive t] + ["Find First Style Error" checkdoc-start t] + ["Find First Style or Spelling Error" checkdoc-ispell-start t] + ["Next Style Error" checkdoc-continue t] + ["Next Style or Spelling Error" checkdoc-ispell-continue t] + ["Interactive Message Text Style Check" checkdoc-message-interactive t] + ["Interactive Message Text Style and Spelling Check" + checkdoc-ispell-message-interactive t] + ["Check Message Text" checkdoc-message-text t] + ["Check and Spell Message Text" checkdoc-ispell-message-text t] + ["Check Comment Style" checkdoc-comments buffer-file-name] + ["Check Comment Style and Spelling" checkdoc-ispell-comments + buffer-file-name] + ["Check for Rogue Spaces" checkdoc-rogue-spaces t] + "---" + ["Check Defun" checkdoc-defun t] + ["Check and Spell Defun" checkdoc-ispell-defun t] + ["Check and Evaluate Defun" checkdoc-eval-defun t] + ["Check and Evaluate Buffer" checkdoc-eval-current-buffer t] + )) ;; XEmacs requires some weird stuff to add this menu in a minor mode. ;; What is it? ;;;###autoload (define-minor-mode checkdoc-minor-mode - "Toggle Checkdoc minor mode, a mode for checking Lisp doc strings. -With prefix ARG, turn Checkdoc minor mode on if ARG is positive, otherwise -turn it off. + "Toggle automatic docstring checking (Checkdoc minor mode). +With a prefix argument ARG, enable Checkdoc minor mode if ARG is +positive, and disable it otherwise. If called from Lisp, enable +the mode if ARG is omitted or nil. In Checkdoc minor mode, the usual bindings for `eval-defun' which is bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-current-buffer' are overridden to include @@ -1369,7 +1360,7 @@ See the style guide in the Emacs Lisp manual for more details." (setq checkdoc-autofix-flag 'never)))) (checkdoc-create-error "You should convert this comment to documentation" - (point) (save-excursion (end-of-line) (point)))) + (point) (line-end-position))) (checkdoc-create-error (if (nth 2 fp) "All interactive functions should have documentation" @@ -1377,12 +1368,8 @@ See the style guide in the Emacs Lisp manual for more details." documentation string") (point) (+ (point) 1) t))))) (if (and (not err) (looking-at "\"")) - (let ((old-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table checkdoc-syntax-table) - (checkdoc-this-string-valid-engine fp)) - (set-syntax-table old-syntax-table))) + (with-syntax-table checkdoc-syntax-table + (checkdoc-this-string-valid-engine fp)) err))) (defun checkdoc-this-string-valid-engine (fp) @@ -1391,7 +1378,7 @@ Depends on `checkdoc-this-string-valid' to reset the syntax table so that regexp short cuts work. FP is the function defun information." (let ((case-fold-search nil) ;; Use a marker so if an early check modifies the text, - ;; we won't accidentally loose our place. This could cause + ;; we won't accidentally lose our place. This could cause ;; end-of doc string whitespace to also delete the " char. (s (point)) (e (if (looking-at "\"") @@ -1489,12 +1476,10 @@ regexp short cuts work. FP is the function defun information." "First line not a complete sentence. Add RET here? " "\n" t) (let (l1 l2) - (forward-line 1) - (end-of-line) + (end-of-line 2) (setq l1 (current-column) l2 (save-excursion - (forward-line 1) - (end-of-line) + (end-of-line 2) (current-column))) (if (> (+ l1 l2 1) 80) (setq msg "Incomplete auto-fix; doc string \ @@ -1511,10 +1496,7 @@ may require more formatting") (forward-line 1) (beginning-of-line) (if (and (re-search-forward "[.!?:\"]\\([ \t\n]+\\|\"\\)" - (save-excursion - (end-of-line) - (point)) - t) + (line-end-position) t) (< (current-column) numc)) (if (checkdoc-autofix-ask-replace p (1+ p) @@ -1529,9 +1511,7 @@ may require more formatting") (if msg (checkdoc-create-error msg s (save-excursion (goto-char s) - (end-of-line) - (point))) - nil) )))) + (line-end-position)))))))) ;; Continuation of above. Make sure our sentence is capitalized. (save-excursion (skip-chars-forward "\"\\*") @@ -1631,7 +1611,7 @@ function,command,variable,option or symbol." ms1)))))) (if (and (< (point) e) (> (current-column) 80)) (checkdoc-create-error "Some lines are over 80 columns wide" - s (save-excursion (goto-char s) (end-of-line) (point)) )))) + s (save-excursion (goto-char s) (line-end-position)))))) ;; Here we deviate to tests based on a variable or function. ;; We must do this before checking for symbols in quotes because there ;; is a chance that just such a symbol might really be an argument. @@ -1776,9 +1756,8 @@ function,command,variable,option or symbol." ms1)))))) (end-of-line) ;; check string-continuation (if (checkdoc-char= (preceding-char) ?\\) - (progn (forward-line 1) - (end-of-line))) - (point))) + (line-end-position 2) + (point)))) (rs nil) replace original (case-fold-search t)) (while (and (not rs) (re-search-forward @@ -1868,7 +1847,7 @@ Replace with \"%s\"? " original replace) ;; and reliance on the Ispell program. (checkdoc-ispell-docstring-engine e) ;; User supplied checks - (save-excursion (checkdoc-run-hooks 'checkdoc-style-hooks fp e)) + (save-excursion (checkdoc-run-hooks 'checkdoc-style-functions fp e)) ;; Done! ))) @@ -1963,7 +1942,7 @@ from the comment." A code fragment is identified by an open parenthesis followed by a symbol which is a valid function or a word in all CAPS, or a parenthesis that is quoted with the ' character. Only the region from START to LIMIT -is is allowed while searching for the bounding parenthesis." +is allowed while searching for the bounding parenthesis." (save-match-data (save-restriction (narrow-to-region start limit) @@ -2004,49 +1983,45 @@ internally skip over no answers. If the offending word is in a piece of quoted text, then it is skipped." (save-excursion (let ((case-fold-search nil) - (errtxt nil) bb be - (old-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table checkdoc-syntax-table) - (goto-char begin) - (while (re-search-forward checkdoc-proper-noun-regexp end t) - (let ((text (match-string 1)) - (b (match-beginning 1)) - (e (match-end 1))) - (if (and (not (save-excursion - (goto-char b) - (forward-char -1) - (looking-at "`\\|\"\\|\\.\\|\\\\"))) - ;; surrounded by /, as in a URL or filename: /emacs/ - (not (and (= ?/ (char-after e)) - (= ?/ (char-before b)))) - (not (checkdoc-in-example-string-p begin end)) - ;; info or url links left alone - (not (thing-at-point-looking-at - help-xref-info-regexp)) - (not (thing-at-point-looking-at - help-xref-url-regexp))) - (if (checkdoc-autofix-ask-replace - b e (format "Text %s should be capitalized. Fix? " - text) - (capitalize text) t) - nil - (if errtxt - ;; If there is already an error, then generate - ;; the warning output if applicable - (if checkdoc-generate-compile-warnings-flag - (checkdoc-create-error - (format - "Name %s should appear capitalized as %s" - text (capitalize text)) - b e)) - (setq errtxt - (format - "Name %s should appear capitalized as %s" - text (capitalize text)) - bb b be e))))))) - (set-syntax-table old-syntax-table)) + (errtxt nil) bb be) + (with-syntax-table checkdoc-syntax-table + (goto-char begin) + (while (re-search-forward checkdoc-proper-noun-regexp end t) + (let ((text (match-string 1)) + (b (match-beginning 1)) + (e (match-end 1))) + (if (and (not (save-excursion + (goto-char b) + (forward-char -1) + (looking-at "`\\|\"\\|\\.\\|\\\\"))) + ;; surrounded by /, as in a URL or filename: /emacs/ + (not (and (= ?/ (char-after e)) + (= ?/ (char-before b)))) + (not (checkdoc-in-example-string-p begin end)) + ;; info or url links left alone + (not (thing-at-point-looking-at + help-xref-info-regexp)) + (not (thing-at-point-looking-at + help-xref-url-regexp))) + (if (checkdoc-autofix-ask-replace + b e (format "Text %s should be capitalized. Fix? " + text) + (capitalize text) t) + nil + (if errtxt + ;; If there is already an error, then generate + ;; the warning output if applicable + (if checkdoc-generate-compile-warnings-flag + (checkdoc-create-error + (format + "Name %s should appear capitalized as %s" + text (capitalize text)) + b e)) + (setq errtxt + (format + "Name %s should appear capitalized as %s" + text (capitalize text)) + bb b be e))))))) (if errtxt (checkdoc-create-error errtxt bb be))))) (defun checkdoc-sentencespace-region-engine (begin end) @@ -2054,43 +2029,39 @@ If the offending word is in a piece of quoted text, then it is skipped." (if sentence-end-double-space (save-excursion (let ((case-fold-search nil) - (errtxt nil) bb be - (old-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table checkdoc-syntax-table) - (goto-char begin) - (while (re-search-forward "[^ .0-9]\\(\\. \\)[^ \n]" end t) - (let ((b (match-beginning 1)) - (e (match-end 1))) - (unless (or (checkdoc-in-sample-code-p begin end) - (checkdoc-in-example-string-p begin end) - (save-excursion - (goto-char b) - (condition-case nil - (progn - (forward-sexp -1) - ;; piece of an abbreviation - ;; FIXME etc - (looking-at - "\\([a-z]\\|[iI]\\.?e\\|[eE]\\.?g\\)\\.")) - (error t)))) - (if (checkdoc-autofix-ask-replace - b e - "There should be two spaces after a period. Fix? " - ". ") - nil - (if errtxt - ;; If there is already an error, then generate - ;; the warning output if applicable - (if checkdoc-generate-compile-warnings-flag - (checkdoc-create-error - "There should be two spaces after a period" - b e)) - (setq errtxt - "There should be two spaces after a period" - bb b be e))))))) - (set-syntax-table old-syntax-table)) + (errtxt nil) bb be) + (with-syntax-table checkdoc-syntax-table + (goto-char begin) + (while (re-search-forward "[^ .0-9]\\(\\. \\)[^ \n]" end t) + (let ((b (match-beginning 1)) + (e (match-end 1))) + (unless (or (checkdoc-in-sample-code-p begin end) + (checkdoc-in-example-string-p begin end) + (save-excursion + (goto-char b) + (condition-case nil + (progn + (forward-sexp -1) + ;; piece of an abbreviation + ;; FIXME etc + (looking-at + "\\([a-zA-Z]\\|[iI]\\.?e\\|[eE]\\.?g\\)\\.")) + (error t)))) + (if (checkdoc-autofix-ask-replace + b e + "There should be two spaces after a period. Fix? " + ". ") + nil + (if errtxt + ;; If there is already an error, then generate + ;; the warning output if applicable + (if checkdoc-generate-compile-warnings-flag + (checkdoc-create-error + "There should be two spaces after a period" + b e)) + (setq errtxt + "There should be two spaces after a period" + bb b be e))))))) (if errtxt (checkdoc-create-error errtxt bb be)))))) ;;; Ispell engine @@ -2146,7 +2117,7 @@ before using the Ispell engine on it." ;; Find out how we spell-check this word. (if (or ;; All caps w/ option th, or s tacked on the end - ;; for pluralization or numberthness. + ;; for pluralization or number. (string-match "^[A-Z][A-Z]+\\(s\\|th\\)?$" word) (looking-at "}") ; a keymap expression ) @@ -2258,8 +2229,8 @@ Code:, and others referenced in the style guide." (insert ";;; " fn fe " --- " (read-string "Summary: ") "\n")) (checkdoc-create-error "The first line should be of the form: \";;; package --- Summary\"" - (point-min) (save-excursion (goto-char (point-min)) (end-of-line) - (point)))) + (point-min) (save-excursion (goto-char (point-min)) + (line-end-position)))) nil)) (setq err @@ -2386,7 +2357,7 @@ Code:, and others referenced in the style guide." err (or ;; Generic Full-file checks (should be comment related) - (checkdoc-run-hooks 'checkdoc-comment-style-hooks) + (checkdoc-run-hooks 'checkdoc-comment-style-functions) err)) ;; Done with full file comment checks err))) @@ -2670,16 +2641,8 @@ function called to create the messages." (setq checkdoc-pending-errors nil) nil))) -(custom-add-option 'emacs-lisp-mode-hook - (lambda () (checkdoc-minor-mode 1))) - -(add-to-list 'debug-ignored-errors - "Argument `.*' should appear (as .*) in the doc string") -(add-to-list 'debug-ignored-errors - "Lisp symbol `.*' should appear in quotes") -(add-to-list 'debug-ignored-errors "Disambiguate .* by preceding .*") +(custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode) (provide 'checkdoc) -;; arch-tag: c49a7ec8-3bb7-46f2-bfbc-d5f26e033b26 ;;; checkdoc.el ends here diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 2b1b3d9b1e4..b90df7092ea 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -1,10 +1,10 @@ -;;; cl-extra.el --- Common Lisp features, part 2 +;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2000-2013 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -37,12 +37,12 @@ ;;; Code: -(require 'cl) +(require 'cl-lib) ;;; Type coercion. ;;;###autoload -(defun coerce (x type) +(defun cl-coerce (x type) "Coerce OBJECT to type TYPE. TYPE is a Common Lisp type specifier. \n(fn OBJECT TYPE)" @@ -51,16 +51,16 @@ TYPE is a Common Lisp type specifier. ((eq type 'string) (if (stringp x) x (concat x))) ((eq type 'array) (if (arrayp x) x (vconcat x))) ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) - ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) + ((and (eq type 'character) (symbolp x)) (cl-coerce (symbol-name x) type)) ((eq type 'float) (float x)) - ((typep x type) x) + ((cl-typep x type) x) (t (error "Can't coerce %s to type %s" x type)))) ;;; Predicates. ;;;###autoload -(defun equalp (x y) +(defun cl-equalp (x y) "Return 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 @@ -73,14 +73,14 @@ strings case-insensitively." ((numberp x) (and (numberp y) (= x y))) ((consp x) - (while (and (consp x) (consp y) (equalp (car x) (car y))) + (while (and (consp x) (consp y) (cl-equalp (car x) (car y))) (setq x (cdr x) y (cdr y))) - (and (not (consp x)) (equalp x y))) + (and (not (consp x)) (cl-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)))) + (cl-equalp (aref x i) (aref y i)))) (< i 0)))) (t (equal x y)))) @@ -88,7 +88,7 @@ strings case-insensitively." ;;; Control structures. ;;;###autoload -(defun cl-mapcar-many (cl-func cl-seqs) +(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))) @@ -115,23 +115,23 @@ strings case-insensitively." (cl-i -1)) (while (< (setq cl-i (1+ cl-i)) cl-n) (push (funcall cl-func - (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) - (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) - cl-res))) + (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) + (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) + cl-res))) (nreverse cl-res)))) ;;;###autoload -(defun map (cl-type cl-func cl-seq &rest cl-rest) +(defun cl-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. \n(fn TYPE FUNCTION SEQUENCE...)" - (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) - (and cl-type (coerce cl-res cl-type)))) + (let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest))) + (and cl-type (cl-coerce cl-res cl-type)))) ;;;###autoload -(defun maplist (cl-func cl-list &rest cl-rest) +(defun cl-maplist (cl-func cl-list &rest cl-rest) "Map FUNCTION to each sublist of LIST or LISTs. -Like `mapcar', except applies to lists and their cdr's rather than to +Like `cl-mapcar', except applies to lists and their cdr's rather than to the elements themselves. \n(fn FUNCTION LIST...)" (if cl-rest @@ -149,44 +149,45 @@ the elements themselves. (setq cl-list (cdr cl-list))) (nreverse cl-res)))) +;;;###autoload (defun cl-mapc (cl-func cl-seq &rest cl-rest) - "Like `mapcar', but does not accumulate values returned by the function. + "Like `cl-mapcar', but does not accumulate values returned by the function. \n(fn FUNCTION SEQUENCE...)" (if cl-rest - (progn (apply 'map nil cl-func cl-seq cl-rest) + (progn (apply 'cl-map nil cl-func cl-seq cl-rest) cl-seq) (mapc cl-func cl-seq))) ;;;###autoload -(defun mapl (cl-func cl-list &rest cl-rest) - "Like `maplist', but does not accumulate values returned by the function. +(defun cl-mapl (cl-func cl-list &rest cl-rest) + "Like `cl-maplist', but does not accumulate values returned by the function. \n(fn FUNCTION LIST...)" (if cl-rest - (apply 'maplist cl-func cl-list cl-rest) + (apply 'cl-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) ;;;###autoload -(defun mapcan (cl-func cl-seq &rest cl-rest) - "Like `mapcar', but nconc's together the values returned by the function. +(defun cl-mapcan (cl-func cl-seq &rest cl-rest) + "Like `cl-mapcar', but nconc's together the values returned by the function. \n(fn FUNCTION SEQUENCE...)" - (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) + (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest))) ;;;###autoload -(defun mapcon (cl-func cl-list &rest cl-rest) - "Like `maplist', but nconc's together the values returned by the function. +(defun cl-mapcon (cl-func cl-list &rest cl-rest) + "Like `cl-maplist', but nconc's together the values returned by the function. \n(fn FUNCTION LIST...)" - (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) + (apply 'nconc (apply 'cl-maplist cl-func cl-list cl-rest))) ;;;###autoload -(defun some (cl-pred cl-seq &rest cl-rest) +(defun cl-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. \n(fn PREDICATE SEQ...)" (if (or cl-rest (nlistp cl-seq)) (catch 'cl-some - (apply 'map nil + (apply 'cl-map nil (function (lambda (&rest cl-x) (let ((cl-res (apply cl-pred cl-x))) (if cl-res (throw 'cl-some cl-res))))) @@ -196,12 +197,12 @@ If so, return the true (non-nil) value returned by PREDICATE. cl-x))) ;;;###autoload -(defun every (cl-pred cl-seq &rest cl-rest) +(defun cl-every (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is true of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" (if (or cl-rest (nlistp cl-seq)) (catch 'cl-every - (apply 'map nil + (apply 'cl-map nil (function (lambda (&rest cl-x) (or (apply cl-pred cl-x) (throw 'cl-every nil)))) cl-seq cl-rest) t) @@ -210,23 +211,19 @@ If so, return the true (non-nil) value returned by PREDICATE. (null cl-seq))) ;;;###autoload -(defun notany (cl-pred cl-seq &rest cl-rest) +(defun cl-notany (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" - (not (apply 'some cl-pred cl-seq cl-rest))) + (not (apply 'cl-some cl-pred cl-seq cl-rest))) ;;;###autoload -(defun notevery (cl-pred cl-seq &rest cl-rest) +(defun cl-notevery (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of some element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" - (not (apply 'every cl-pred cl-seq cl-rest))) - -;;; Support for `loop'. -;;;###autoload -(defalias 'cl-map-keymap 'map-keymap) + (not (apply 'cl-every cl-pred cl-seq cl-rest))) ;;;###autoload -(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) +(defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base) (or cl-base (setq cl-base (copy-sequence [0]))) (map-keymap @@ -234,14 +231,14 @@ If so, return the true (non-nil) value returned by PREDICATE. (lambda (cl-key cl-bind) (aset cl-base (1- (length cl-base)) cl-key) (if (keymapp cl-bind) - (cl-map-keymap-recursively + (cl--map-keymap-recursively cl-func-rec cl-bind (vconcat cl-base (list 0))) (funcall cl-func-rec cl-base cl-bind)))) cl-map)) ;;;###autoload -(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) +(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) @@ -269,7 +266,7 @@ If so, return the true (non-nil) value returned by PREDICATE. (setq cl-start cl-next))))) ;;;###autoload -(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) +(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) @@ -311,36 +308,17 @@ If so, return the true (non-nil) value returned by PREDICATE. ;;; Support for `setf'. ;;;###autoload -(defun cl-set-frame-visible-p (frame val) +(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) -;;;###autoload -(defun cl-progv-before (syms values) - (while syms - (push (if (boundp (car syms)) - (cons (car syms) (symbol-value (car syms))) - (car syms)) cl-progv-save) - (if values - (set (pop syms) (pop values)) - (makunbound (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))) - (pop cl-progv-save))) - ;;; Numbers. ;;;###autoload -(defun gcd (&rest args) +(defun cl-gcd (&rest args) "Return the greatest common divisor of the arguments." (let ((a (abs (or (pop args) 0)))) (while args @@ -349,18 +327,18 @@ If so, return the true (non-nil) value returned by PREDICATE. a)) ;;;###autoload -(defun lcm (&rest args) +(defun cl-lcm (&rest args) "Return the least common multiple of the arguments." (if (memq 0 args) 0 (let ((a (abs (or (pop args) 1)))) (while args (let ((b (abs (pop args)))) - (setq a (* (/ a (gcd a b)) b)))) + (setq a (* (/ a (cl-gcd a b)) b)))) a))) ;;;###autoload -(defun isqrt (x) +(defun cl-isqrt (x) "Return the integer square root of the argument." (if (and (integerp x) (> x 0)) (let ((g (cond ((<= x 100) 10) ((<= x 10000) 100) @@ -372,35 +350,35 @@ If so, return the true (non-nil) value returned by PREDICATE. (if (eq x 0) 0 (signal 'arith-error nil)))) ;;;###autoload -(defun floor* (x &optional y) +(defun cl-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))))) ;;;###autoload -(defun ceiling* (x &optional y) +(defun cl-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))) + (let ((res (cl-floor x y))) (if (= (car (cdr res)) 0) res (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) ;;;###autoload -(defun truncate* (x &optional y) +(defun cl-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))) + (cl-floor x y) (cl-ceiling x y))) ;;;###autoload -(defun round* (x &optional y) +(defun cl-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))) + (res (cl-floor (+ x hy) y))) (if (and (= (car (cdr res)) 0) (= (+ hy hy) y) (/= (% (car res) 2) 0)) @@ -413,29 +391,28 @@ With two arguments, return rounding and remainder of their quotient." (list q (- x q)))))) ;;;###autoload -(defun mod* (x y) +(defun cl-mod (x y) "The remainder of X divided by Y, with the same sign as Y." - (nth 1 (floor* x y))) + (nth 1 (cl-floor x y))) ;;;###autoload -(defun rem* (x y) +(defun cl-rem (x y) "The remainder of X divided by Y, with the same sign as X." - (nth 1 (truncate* x y))) + (nth 1 (cl-truncate x y))) ;;;###autoload -(defun signum (x) +(defun cl-signum (x) "Return 1 if X is positive, -1 if negative, 0 if zero." (cond ((> x 0) 1) ((< x 0) -1) (t 0))) ;; Random numbers. -(defvar *random-state*) ;;;###autoload -(defun random* (lim &optional state) +(defun cl-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*)) + (or state (setq state cl--random-state)) ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. (let ((vec (aref state 3))) (if (integerp vec) @@ -444,29 +421,29 @@ Optional second arg STATE is a random-state object." (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)))) + (while (< (setq i (1+ i)) 200) (cl-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)))) + (if (> lim 8388607) (setq n (+ (lsh n 9) (cl-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)))) + (if (< (setq n (logand n mask)) lim) n (cl-random lim state)))) (* (/ n '8388608e0) lim))))) ;;;###autoload -(defun make-random-state (&optional state) - "Return a copy of random-state STATE, or of `*random-state*' if omitted. +(defun cl-make-random-state (&optional state) + "Return a copy of random-state STATE, or of the internal 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)) + (cond ((null state) (cl-make-random-state cl--random-state)) + ((vectorp state) (copy-tree state t)) ((integerp state) (vector 'cl-random-state-tag -1 30 state)) - (t (make-random-state (cl-random-time))))) + (t (cl-make-random-state (cl-random-time))))) ;;;###autoload -(defun random-state-p (object) +(defun cl-random-state-p (object) "Return t if OBJECT is a random-state object." (and (vectorp object) (= (length object) 4) (eq (aref object 0) 'cl-random-state-tag))) @@ -474,64 +451,64 @@ If STATE is t, return a new state object seeded from the time of day." ;; Implementation limits. -(defun cl-finite-do (func a b) - (condition-case err +(defun cl--finite-do (func a b) + (condition-case _ (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) - ;;;###autoload (defun cl-float-limits () - (or most-positive-float (not (numberp '2e1)) + "Initialize the Common Lisp floating-point parameters. +This sets the values of: `cl-most-positive-float', `cl-most-negative-float', +`cl-least-positive-float', `cl-least-negative-float', `cl-float-epsilon', +`cl-float-negative-epsilon', `cl-least-positive-normalized-float', and +`cl-least-negative-normalized-float'." + (or cl-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))) + (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)) + ;; Now cl-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)) + (setq cl-most-positive-float x + cl-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)) + (while (condition-case _ (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)) + (setq cl-least-positive-normalized-float y + cl-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)) + (while (condition-case _ (> (/ x 2) 0) (arith-error nil)) (setq x (/ x 2))) - (setq least-positive-float x - least-negative-float (- x)) + (setq cl-least-positive-float x + cl-least-negative-float (- x)) (setq x '1e0) (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2))) - (setq float-epsilon (* x 2)) + (setq cl-float-epsilon (* x 2)) (setq x '1e0) (while (/= (- '1e0 x) '1e0) (setq x (/ x 2))) - (setq float-negative-epsilon (* x 2)))) + (setq cl-float-negative-epsilon (* x 2)))) nil) ;;; Sequence functions. ;;;###autoload -(defun subseq (seq start &optional end) +(defun cl-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." + (declare (gv-setter + (lambda (new) + `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) + ,new)))) (if (stringp seq) (substring seq start end) (let (len) (and end (< end 0) (setq end (+ end (setq len (length seq))))) @@ -554,7 +531,7 @@ If START or END is negative, it counts from the end." res)))))) ;;;###autoload -(defun concatenate (type &rest seqs) +(defun cl-concatenate (type &rest seqs) "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. \n(fn TYPE SEQUENCE...)" (cond ((eq type 'vector) (apply 'vconcat seqs)) @@ -566,17 +543,17 @@ If START or END is negative, it counts from the end." ;;; List functions. ;;;###autoload -(defun revappend (x y) +(defun cl-revappend (x y) "Equivalent to (append (reverse X) Y)." (nconc (reverse x) y)) ;;;###autoload -(defun nreconc (x y) +(defun cl-nreconc (x y) "Equivalent to (nconc (nreverse X) Y)." (nconc (nreverse x) y)) ;;;###autoload -(defun list-length (x) +(defun cl-list-length (x) "Return the length of list X. Return nil if list is circular." (let ((n 0) (fast x) (slow x)) (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) @@ -584,51 +561,62 @@ If START or END is negative, it counts from the end." (if fast (if (cdr fast) nil (1+ n)) n))) ;;;###autoload -(defun tailp (sublist list) +(defun cl-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))) -(defalias 'cl-copy-tree 'copy-tree) - - ;;; Property lists. ;;;###autoload -(defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el +(defun cl-get (sym tag &optional def) "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. \n(fn SYMBOL PROPNAME &optional DEFAULT)" + (declare (compiler-macro cl--compiler-macro-get) + (gv-setter (lambda (store) `(put ,sym ,tag ,store)))) (or (get sym tag) (and def + ;; Make sure `def' is really absent as opposed to set to nil. (let ((plist (symbol-plist sym))) (while (and plist (not (eq (car plist) tag))) (setq plist (cdr (cdr plist)))) (if plist (car (cdr plist)) def))))) +(autoload 'cl--compiler-macro-get "cl-macs") ;;;###autoload -(defun getf (plist tag &optional def) +(defun cl-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'. \n(fn PROPLIST PROPNAME &optional DEFAULT)" + (declare (gv-expander + (lambda (do) + (gv-letplace (getter setter) plist + (macroexp-let2 nil k tag + (macroexp-let2 nil d def + (funcall do `(cl-getf ,getter ,k ,d) + (lambda (v) + (funcall setter + `(cl--set-getf ,getter ,k ,v)))))))))) (setplist '--cl-getf-symbol-- plist) (or (get '--cl-getf-symbol-- tag) - ;; Originally we called get* here, - ;; but that fails, because get* has a compiler macro + ;; Originally we called cl-get here, + ;; but that fails, because cl-get has a compiler macro ;; definition that uses getf! (when def + ;; Make sure `def' is really absent as opposed to set to nil. (while (and plist (not (eq (car plist) tag))) (setq plist (cdr (cdr plist)))) (if plist (car (cdr plist)) def)))) ;;;###autoload -(defun cl-set-getf (plist tag val) +(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)))) + (if p (progn (setcar (cdr p) val) plist) (cl-list* tag val plist)))) ;;;###autoload -(defun cl-do-remf (plist tag) +(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)))) @@ -640,41 +628,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (let ((plist (symbol-plist sym))) (if (and plist (eq tag (car plist))) (progn (setplist sym (cdr (cdr plist))) t) - (cl-do-remf plist tag)))) -;;;###autoload -(defalias 'remprop 'cl-remprop) - - - -;;; Hash tables. -;; This is just kept for compatibility with code byte-compiled by Emacs-20. - -;; No idea if this might still be needed. -(defun cl-not-hash-table (x &optional y &rest z) - (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) - -(defvar cl-builtin-gethash (symbol-function 'gethash)) -(defvar cl-builtin-remhash (symbol-function 'remhash)) -(defvar cl-builtin-clrhash (symbol-function 'clrhash)) -(defvar cl-builtin-maphash (symbol-function 'maphash)) - -;;;###autoload -(defalias 'cl-gethash 'gethash) -;;;###autoload -(defalias 'cl-puthash 'puthash) -;;;###autoload -(defalias 'cl-remhash 'remhash) -;;;###autoload -(defalias 'cl-clrhash 'clrhash) -;;;###autoload -(defalias 'cl-maphash 'maphash) -;; These three actually didn't exist in Emacs-20. -;;;###autoload -(defalias 'cl-make-hash-table 'make-hash-table) -;;;###autoload -(defalias 'cl-hash-table-p 'hash-table-p) -;;;###autoload -(defalias 'cl-hash-table-count 'hash-table-count) + (cl--do-remf plist tag)))) ;;; Some debugging aids. @@ -685,20 +639,20 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (setq last (point)) (goto-char (1+ pt)) (while (search-forward "(quote " last t) - (delete-backward-char 7) + (delete-char -7) (insert "'") (forward-sexp) (delete-char 1)) (goto-char (1+ pt)) - (cl-do-prettyprint))) + (cl--do-prettyprint))) -(defun 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 "))) + (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] "))) @@ -708,109 +662,27 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (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)) + (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)) + (cl--do-prettyprint)) (forward-char 1)))) (forward-sexp))) -(defvar cl-macroexpand-cmacs nil) -(defvar cl-closure-vars nil) - -;;;###autoload -(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 - (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)) - (push (list 'quote (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 '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 (and found (ignore-errors - (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)))) - ((consp (car form)) - (cl-macroexpand-all (list* 'funcall - (list 'function (car form)) - (cdr form)) - env)) - (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)) - ;;;###autoload (defun cl-prettyexpand (form &optional full) + "Expand macros in FORM and insert the pretty-printed result. +Optional argument FULL non-nil means to expand all macros, +including `cl-block' and `cl-eval-when'." (message "Expanding...") - (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) + (let ((cl--compiling-file full) (byte-compile-macro-environment nil)) - (setq form (cl-macroexpand-all form - (and (not full) '((block) (eval-when))))) + (setq form (macroexpand-all form + (and (not full) '((cl-block) (cl-eval-when))))) (message "Formatting...") (prog1 (cl-prettyprint form) (message "")))) @@ -821,9 +693,7 @@ This also does some trivial optimizations to make the form prettier." ;; Local variables: ;; byte-compile-dynamic: t -;; byte-compile-warnings: (not cl-functions) ;; generated-autoload-file: "cl-loaddefs.el" ;; End: -;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed ;;; cl-extra.el ends here diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index c67a2180c3b..599cf3ac345 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -1,12 +1,12 @@ ;;; cl-indent.el --- enhanced lisp-indent mode -;; Copyright (C) 1987, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1987, 2000-2013 Free Software Foundation, Inc. ;; Author: Richard Mlynarik <mly@eddie.mit.edu> ;; Created: July 1987 ;; Maintainer: FSF ;; Keywords: lisp, tools +;; Package: emacs ;; This file is part of GNU Emacs. @@ -31,22 +31,10 @@ ;; ;; (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: +(eval-when-compile (require 'cl)) + (defgroup lisp-indent nil "Indentation in Lisp." :group 'lisp) @@ -101,9 +89,58 @@ If nil, indent backquoted lists as data, i.e., like quoted lists." :type 'integer :group 'lisp-indent) +(defcustom lisp-lambda-list-keyword-alignment nil + "Whether to vertically align lambda-list keywords together. +If nil (the default), keyworded lambda-list parts are aligned +with the initial mandatory arguments, like this: + +\(defun foo (arg1 arg2 &rest rest + &key key1 key2) + #|...|#) + +If non-nil, alignment is done with the first keyword +\(or falls back to the previous case), as in: + +\(defun foo (arg1 arg2 &rest rest + &key key1 key2) + #|...|#)" + :version "24.1" + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-lambda-list-keyword-parameter-indentation 2 + "Indentation of lambda list keyword parameters. +See `lisp-lambda-list-keyword-parameter-alignment' +for more information." + :version "24.1" + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-lambda-list-keyword-parameter-alignment nil + "Whether to vertically align lambda-list keyword parameters together. +If nil (the default), the parameters are aligned +with their corresponding keyword, plus the value of +`lisp-lambda-list-keyword-parameter-indentation', like this: + +\(defun foo (arg1 arg2 &key key1 key2 + key3 key4) + #|...|#) + +If non-nil, alignment is done with the first parameter +\(or falls back to the previous case), as in: + +\(defun foo (arg1 arg2 &key key1 key2 + key3 key4) + #|...|#)" + :version "24.1" + :type 'boolean + :group 'lisp-indent) + (defvar lisp-indent-defun-method '(4 &lambda &body) - "Indentation for function with `common-lisp-indent-function' property `defun'.") + "Defun-like indentation method. +This applies when the value of the `common-lisp-indent-function' property +is set to `defun'.") (defun extended-loop-p (loop-start) @@ -125,14 +162,19 @@ If nil, indent backquoted lists as data, i.e., like quoted lists." (current-column)))) (goto-char indent-point) (beginning-of-line) - (cond ((not (extended-loop-p (elt state 1))) - (+ loop-indentation lisp-simple-loop-indentation)) - ((looking-at "^\\s-*\\(:?\\sw+\\|;\\)") - (+ loop-indentation lisp-loop-keyword-indentation)) - (t - (+ loop-indentation lisp-loop-forms-indentation))))) - - + (list + (cond ((not (extended-loop-p (elt state 1))) + (+ loop-indentation lisp-simple-loop-indentation)) + ((looking-at "^\\s-*\\(:?\\sw+\\|;\\)") + (+ loop-indentation lisp-loop-keyword-indentation)) + (t + (+ loop-indentation lisp-loop-forms-indentation))) + ;; Tell the caller that the next line needs recomputation, even + ;; though it doesn't start a sexp. + loop-indentation))) + + +;; Cf (info "(elisp)Specification List") ;;;###autoload (defun common-lisp-indent-function (indent-point state) "Function to indent the arguments of a Lisp function call. @@ -144,7 +186,7 @@ indentation function is called, and STATE is the of this function. If the indentation point is in a call to a Lisp function, that -function's common-lisp-indent-function property specifies how +function's `common-lisp-indent-function' property specifies how this function should indent it. Possible values for this property are: @@ -217,8 +259,7 @@ For example, the function `case' has an indent property (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)' - ;; (Surely (0 3 1)?). + ;; `foo' has a path of (0 3 1) in `((a b c (d foo) f) g)'. (path ()) ;; set non-nil when somebody works out the indentation to use calculated @@ -381,10 +422,74 @@ For example, the function `case' has an indent property ;; Love those free variable references!! lisp-indent-error-function 'common-lisp-indent-function m)) + +;; Lambda-list indentation is now done in LISP-INDENT-LAMBDA-LIST. +;; See also `lisp-lambda-list-keyword-alignment', +;; `lisp-lambda-list-keyword-parameter-alignment' and +;; `lisp-lambda-list-keyword-parameter-indentation' -- dvl + +(defvar lisp-indent-lambda-list-keywords-regexp + "&\\(\ +optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\ +\\)\\([ \t]\\|$\\)" + "Regular expression matching lambda-list keywords.") + +(defun lisp-indent-lambda-list + (indent-point sexp-column containing-form-start) + (let (limit) + (cond ((save-excursion + (goto-char indent-point) + (beginning-of-line) + (skip-chars-forward " \t") + (setq limit (point)) + (looking-at lisp-indent-lambda-list-keywords-regexp)) + ;; We're facing a lambda-list keyword. + (if lisp-lambda-list-keyword-alignment + ;; Align to the first keyword if any, or to the beginning of + ;; the lambda-list. + (save-excursion + (goto-char containing-form-start) + (save-match-data + (if (re-search-forward + lisp-indent-lambda-list-keywords-regexp + limit t) + (progn + (goto-char (match-beginning 0)) + (current-column)) + (1+ sexp-column)))) + ;; Align to the beginning of the lambda-list. + (1+ sexp-column))) + (t + ;; Otherwise, align to the first argument of the last lambda-list + ;; keyword, the keyword itself, or the beginning of the + ;; lambda-list. + (save-excursion + (goto-char indent-point) + (forward-line -1) + (end-of-line) + (save-match-data + (if (re-search-backward lisp-indent-lambda-list-keywords-regexp + containing-form-start t) + (let* ((keyword-posn + (progn + (goto-char (match-beginning 0)) + (current-column))) + (indented-keyword-posn + (+ keyword-posn + lisp-lambda-list-keyword-parameter-indentation))) + (goto-char (match-end 0)) + (skip-chars-forward " \t") + (if (eolp) + indented-keyword-posn + (if lisp-lambda-list-keyword-parameter-alignment + (current-column) + indented-keyword-posn))) + (1+ sexp-column)))))))) + ;; Blame the crufty control structure on dynamic scoping ;; -- not on me! -(defun lisp-indent-259 (method path state indent-point - sexp-column normal-indent) +(defun lisp-indent-259 + (method path state indent-point sexp-column normal-indent) (catch 'exit (let ((p path) (containing-form-start (elt state 1)) @@ -452,8 +557,14 @@ For example, the function `case' has an indent property (cond ((null p) (list (+ sexp-column 4) containing-form-start)) ((null (cdr p)) - (+ sexp-column 1)) - (t normal-indent)))) + ;; Indentation within a lambda-list. -- dvl + (list (lisp-indent-lambda-list + indent-point + sexp-column + containing-form-start) + containing-form-start)) + (t + normal-indent)))) ((integerp tem) (throw 'exit (if (null p) ;not in subforms @@ -523,19 +634,26 @@ For example, the function `case' has an indent property path state indent-point sexp-column normal-indent))) -(defun lisp-indent-defmethod (path state indent-point sexp-column - normal-indent) - "Indentation function defmethod." - (lisp-indent-259 (if (and (>= (car path) 3) - (null (cdr path)) - (save-excursion (goto-char (elt state 1)) - (forward-char 1) - (forward-sexp 3) - (backward-sexp) - (looking-at ":\\|\\sw+"))) - '(4 4 (&whole 4 &rest 4) &body) - (get 'defun 'common-lisp-indent-function)) - path state indent-point sexp-column normal-indent)) +;; LISP-INDENT-DEFMETHOD now supports the presence of more than one method +;; qualifier and indents the method's lambda list properly. -- dvl +(defun lisp-indent-defmethod + (path state indent-point sexp-column normal-indent) + (lisp-indent-259 + (let ((nqual 0)) + (if (and (>= (car path) 3) + (save-excursion + (beginning-of-defun) + (forward-char 1) + (forward-sexp 2) + (skip-chars-forward " \t\n") + (while (looking-at "\\sw\\|\\s_") + (incf nqual) + (forward-sexp) + (skip-chars-forward " \t\n")) + (> nqual 0))) + (append '(4) (make-list nqual 4) '(&lambda &body)) + (get 'defun 'common-lisp-indent-function))) + path state indent-point sexp-column normal-indent)) (defun lisp-indent-function-lambda-hack (path state indent-point @@ -577,6 +695,7 @@ For example, the function `case' has an indent property (define-modify-macro (4 &lambda &body)) (defsetf (4 &lambda 4 &body)) (defun (4 &lambda &body)) + (defgeneric (4 &lambda &body)) (define-setf-method . defun) (define-setf-expander . defun) (defmacro . defun) @@ -690,5 +809,4 @@ For example, the function `case' has an indent property ;(put 'defclass 'common-lisp-indent-function '((&whole 2 &rest (&whole 2 &rest 1) &rest (&whole 2 &rest 1))) ;(put 'defgeneric 'common-lisp-indent-function 'defun) -;; arch-tag: 7914d50f-92ec-4476-93fc-0f043a380e03 ;;; cl-indent.el ends here diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el new file mode 100644 index 00000000000..226e9607b40 --- /dev/null +++ b/lisp/emacs-lisp/cl-lib.el @@ -0,0 +1,748 @@ +;;; cl-lib.el --- Common Lisp extensions for Emacs -*- lexical-binding: t -*- + +;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. + +;; Author: Dave Gillespie <daveg@synaptics.com> +;; Version: 1.0 +;; 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; 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. +;; +;; 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: + +(require 'macroexp) + +(defvar cl-optimize-speed 1) +(defvar cl-optimize-safety 1) + +;;;###autoload +(define-obsolete-variable-alias + ;; This alias is needed for compatibility with .elc files that use defstruct + ;; and were compiled with Emacs<24.3. + 'custom-print-functions 'cl-custom-print-functions "24.3") + +;;;###autoload +(defvar cl-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.") + +;;; Generalized variables. +;; These macros are defined here so that they +;; can safely be used in init files. + +(defmacro cl-incf (place &optional 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." + (declare (debug (place &optional form))) + (if (symbolp place) + (list 'setq place (if x (list '+ place x) (list '1+ place))) + (list 'cl-callf '+ place (or x 1)))) + +(defmacro cl-decf (place &optional 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." + (declare (debug cl-incf)) + (if (symbolp place) + (list 'setq place (if x (list '- place x) (list '1- place))) + (list 'cl-callf '- place (or x 1)))) + +(defmacro cl-pushnew (x place &rest keys) + "(cl-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. +\nKeywords supported: :test :test-not :key +\n(fn X PLACE [KEYWORD VALUE]...)" + (declare (debug + (form place &rest + &or [[&or ":test" ":test-not" ":key"] function-form] + [keywordp form]))) + (if (symbolp place) + (if (null keys) + (macroexp-let2 nil var x + `(if (memql ,var ,place) + ;; This symbol may later on expand to actual code which then + ;; trigger warnings like "value unused" since cl-pushnew's + ;; return value is rarely used. It should not matter that + ;; other warnings may be silenced, since `place' is used + ;; earlier and should have triggered them already. + (with-no-warnings ,place) + (setq ,place (cons ,var ,place)))) + (list 'setq place (cl-list* 'cl-adjoin x place keys))) + (cl-list* 'cl-callf2 'cl-adjoin x place keys))) + +(defun cl--set-elt (seq n val) + (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) + +(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) (cl-incf end (length str))) + (setq end (length str))) + (if (< start 0) (cl-incf start (length str))) + (concat (and (> start 0) (substring str 0 start)) + val + (and (< end (length str)) (substring str end)))) + + +;;; 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, cl-multiple-value-bind and friends simply expect +;; the target form to return the values as a list. + +(defun cl--defalias (cl-f el-f &optional doc) + (defalias cl-f el-f doc) + (put cl-f 'byte-optimizer 'byte-compile-inline-expand)) + +(cl--defalias 'cl-values #'list + "Return multiple values, Common Lisp style. +The arguments of `cl-values' are the values +that the containing function should return. + +\(fn &rest VALUES)") + +(cl--defalias 'cl-values-list #'identity + "Return multiple values, Common Lisp style, taken from a list. +LIST specifies the list of values +that the containing function should return. + +\(fn LIST)") + +(defsubst cl-multiple-value-list (expression) + "Return a list of the multiple values produced by EXPRESSION. +This handles multiple values in Common Lisp style, but it does not +work right when EXPRESSION calls an ordinary Emacs Lisp function +that returns just one value." + expression) + +(defsubst cl-multiple-value-apply (function expression) + "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them. +This handles multiple values in Common Lisp style, but it does not work +right when EXPRESSION calls an ordinary Emacs Lisp function that returns just +one value." + (apply function expression)) + +(defalias 'cl-multiple-value-call 'apply + "Apply FUNCTION to ARGUMENTS, taking multiple values into account. +This implementation only handles the case where there is only one argument.") + +(cl--defalias 'cl-nth-value #'nth + "Evaluate EXPRESSION to get multiple values and return the Nth one. +This handles multiple values in Common Lisp style, but it does not work +right when EXPRESSION calls an ordinary Emacs Lisp function that returns just +one value. + +\(fn N EXPRESSION)") + +;;; Declarations. + +(defvar cl--compiling-file nil) +(defun cl--compiling-file () + (or cl--compiling-file + (and (boundp 'byte-compile--outbuffer) + (bufferp (symbol-value 'byte-compile--outbuffer)) + (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) + " *Compiler Output*")))) + +(defvar cl-proclaims-deferred nil) + +(defun cl-proclaim (spec) + "Record a global declaration specified by SPEC." + (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) + (push spec cl-proclaims-deferred)) + nil) + +(defmacro cl-declaim (&rest specs) + "Like `cl-proclaim', but takes any number of unevaluated, unquoted arguments. +Puts `(cl-eval-when (compile load eval) ...)' around the declarations +so that they are registered at compile-time as well as run-time." + (let ((body (mapcar (function (lambda (x) + (list 'cl-proclaim (list 'quote x)))) + specs))) + (if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body) + (cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when + + +;;; Symbols. + +(defun cl-random-time () + (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) + (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) + v)) + +(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100)) + + +;;; Numbers. + +(defun cl-floatp-safe (object) + "Return t if OBJECT is a floating point number. +On Emacs versions that lack floating-point support, this function +always returns nil." + (and (numberp object) (not (integerp object)))) + +(defsubst cl-plusp (number) + "Return t if NUMBER is positive." + (> number 0)) + +(defsubst cl-minusp (number) + "Return t if NUMBER is negative." + (< number 0)) + +(defun cl-oddp (integer) + "Return t if INTEGER is odd." + (eq (logand integer 1) 1)) + +(defun cl-evenp (integer) + "Return t if INTEGER is even." + (eq (logand integer 1) 0)) + +(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time))) + +(defconst cl-most-positive-float nil + "The largest value that a Lisp float can hold. +If your system supports infinities, this is the largest finite value. +For IEEE machines, this is approximately 1.79e+308. +Call `cl-float-limits' to set this.") + +(defconst cl-most-negative-float nil + "The largest negative value that a Lisp float can hold. +This is simply -`cl-most-positive-float'. +Call `cl-float-limits' to set this.") + +(defconst cl-least-positive-float nil + "The smallest value greater than zero that a Lisp float can hold. +For IEEE machines, it is about 4.94e-324 if denormals are supported, +or 2.22e-308 if they are not. +Call `cl-float-limits' to set this.") + +(defconst cl-least-negative-float nil + "The smallest value less than zero that a Lisp float can hold. +This is simply -`cl-least-positive-float'. +Call `cl-float-limits' to set this.") + +(defconst cl-least-positive-normalized-float nil + "The smallest normalized Lisp float greater than zero. +This is the smallest value for which IEEE denormalization does not lose +precision. For IEEE machines, this value is about 2.22e-308. +For machines that do not support the concept of denormalization +and gradual underflow, this constant equals `cl-least-positive-float'. +Call `cl-float-limits' to set this.") + +(defconst cl-least-negative-normalized-float nil + "The smallest normalized Lisp float less than zero. +This is simply -`cl-least-positive-normalized-float'. +Call `cl-float-limits' to set this.") + +(defconst cl-float-epsilon nil + "The smallest positive float that adds to 1.0 to give a distinct value. +Adding a number less than this to 1.0 returns 1.0 due to roundoff. +For IEEE machines, epsilon is about 2.22e-16. +Call `cl-float-limits' to set this.") + +(defconst cl-float-negative-epsilon nil + "The smallest positive float that subtracts from 1.0 to give a distinct value. +For IEEE machines, it is about 1.11e-16. +Call `cl-float-limits' to set this.") + + +;;; Sequence functions. + +(cl--defalias 'cl-copy-seq 'copy-sequence) + +(declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs)) + +(defun cl-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. +\n(fn FUNCTION SEQ...)" + (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))) + +(cl--defalias 'cl-svref 'aref) + +;;; List functions. + +(cl--defalias 'cl-first 'car) +(cl--defalias 'cl-second 'cadr) +(cl--defalias 'cl-rest 'cdr) +(cl--defalias 'cl-endp 'null) + +(cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.") +(cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.") + +(defsubst cl-fifth (x) + "Return the fifth element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 4 ,x) ,store)))) + (nth 4 x)) + +(defsubst cl-sixth (x) + "Return the sixth element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 5 ,x) ,store)))) + (nth 5 x)) + +(defsubst cl-seventh (x) + "Return the seventh element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 6 ,x) ,store)))) + (nth 6 x)) + +(defsubst cl-eighth (x) + "Return the eighth element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 7 ,x) ,store)))) + (nth 7 x)) + +(defsubst cl-ninth (x) + "Return the ninth element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 8 ,x) ,store)))) + (nth 8 x)) + +(defsubst cl-tenth (x) + "Return the tenth element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 9 ,x) ,store)))) + (nth 9 x)) + +(defun cl-caaar (x) + "Return the `car' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (car (car x)))) + +(defun cl-caadr (x) + "Return the `car' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (car (cdr x)))) + +(defun cl-cadar (x) + "Return the `car' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (cdr (car x)))) + +(defun cl-caddr (x) + "Return the `car' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (cdr (cdr x)))) + +(defun cl-cdaar (x) + "Return the `cdr' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (cdr (car (car x)))) + +(defun cl-cdadr (x) + "Return the `cdr' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (cdr (car (cdr x)))) + +(defun cl-cddar (x) + "Return the `cdr' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (cdr (cdr (car x)))) + +(defun cl-cdddr (x) + "Return the `cdr' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (cdr (cdr (cdr x)))) + +(defun cl-caaaar (x) + "Return the `car' of the `car' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (car (car (car x))))) + +(defun cl-caaadr (x) + "Return the `car' of the `car' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (car (car (cdr x))))) + +(defun cl-caadar (x) + "Return the `car' of the `car' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (car (cdr (car x))))) + +(defun cl-caaddr (x) + "Return the `car' of the `car' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (car (cdr (cdr x))))) + +(defun cl-cadaar (x) + "Return the `car' of the `cdr' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (cdr (car (car x))))) + +(defun cl-cadadr (x) + "Return the `car' of the `cdr' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (cdr (car (cdr x))))) + +(defun cl-caddar (x) + "Return the `car' of the `cdr' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (cdr (cdr (car x))))) + +(defun cl-cadddr (x) + "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (car (cdr (cdr (cdr x))))) + +(defun cl-cdaaar (x) + "Return the `cdr' of the `car' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (cdr (car (car (car x))))) + +(defun cl-cdaadr (x) + "Return the `cdr' of the `car' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (cdr (car (car (cdr x))))) + +(defun cl-cdadar (x) + "Return the `cdr' of the `car' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (cdr (car (cdr (car x))))) + +(defun cl-cdaddr (x) + "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (cdr (car (cdr (cdr x))))) + +(defun cl-cddaar (x) + "Return the `cdr' of the `cdr' of the `car' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (cdr (cdr (car (car x))))) + +(defun cl-cddadr (x) + "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (cdr (cdr (car (cdr x))))) + +(defun cl-cdddar (x) + "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (cdr (cdr (cdr (car x))))) + +(defun cl-cddddr (x) + "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." + (declare (compiler-macro cl--compiler-macro-cXXr)) + (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) (cl-incf m) (pop p)) +;; (if (<= n 0) p +;; (if (< n m) (nthcdr (- m n) x) x))) +;; (while (consp (cdr x)) (pop x)) +;; x)) + +(defun cl-list* (arg &rest rest) + "Return a new list with specified ARGs as elements, consed to last ARG. +Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to +`(cons A (cons B (cons C D)))'. +\n(fn ARG...)" + (declare (compiler-macro cl--compiler-macro-list*)) + (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 cl-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 cl-copy-list (list) + "Return a copy of LIST, which may be a dotted list. +The elements of 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))) + +;; Autoloaded, but we have not loaded cl-loaddefs yet. +(declare-function cl-floor "cl-extra" (x &optional y)) +(declare-function cl-ceiling "cl-extra" (x &optional y)) +(declare-function cl-truncate "cl-extra" (x &optional y)) +(declare-function cl-round "cl-extra" (x &optional y)) +(declare-function cl-mod "cl-extra" (x y)) + +(defun cl-adjoin (cl-item cl-list &rest cl-keys) + "Return ITEM consed onto the front of LIST only if it's not already there. +Otherwise, return LIST unmodified. +\nKeywords supported: :test :test-not :key +\n(fn ITEM LIST [KEYWORD VALUE]...)" + (declare (compiler-macro cl--compiler-macro-adjoin)) + (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 cl-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. +\nKeywords supported: :test :test-not :key +\n(fn NEW OLD TREE [KEYWORD VALUE]...)" + (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) + (apply 'cl-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 cl-acons (key value alist) + "Add KEY and VALUE to ALIST. +Return a new list with (cons KEY VALUE) as car and ALIST as cdr." + (cons (cons key value) alist)) + +(defun cl-pairlis (keys values &optional alist) + "Make an alist from KEYS and VALUES. +Return a new alist composed by associating KEYS to corresponding VALUES; +the process stops as soon as KEYS or VALUES run out. +If ALIST is non-nil, the new pairs are prepended to it." + (nconc (cl-mapcar 'cons keys values) alist)) + + +;;; Generalized variables. + +;; These used to be in cl-macs.el since all macros that use them (like setf) +;; were autoloaded from cl-macs.el. But now that setf, push, and pop are in +;; core Elisp, they need to either be right here or be autoloaded via +;; cl-loaddefs.el, which is more trouble than it is worth. + +;; Some more Emacs-related place types. +(gv-define-simple-setter buffer-file-name set-visited-file-name t) +(gv-define-setter buffer-modified-p (flag &optional buf) + `(with-current-buffer ,buf + (set-buffer-modified-p ,flag))) +(gv-define-simple-setter buffer-name rename-buffer t) +(gv-define-setter buffer-string (store) + `(insert (prog1 ,store (erase-buffer)))) +(gv-define-simple-setter buffer-substring cl--set-buffer-substring) +(gv-define-simple-setter current-buffer set-buffer) +(gv-define-simple-setter current-case-table set-case-table) +(gv-define-simple-setter current-column move-to-column t) +(gv-define-simple-setter current-global-map use-global-map t) +(gv-define-setter current-input-mode (store) + `(progn (apply #'set-input-mode ,store) ,store)) +(gv-define-simple-setter current-local-map use-local-map t) +(gv-define-simple-setter current-window-configuration + set-window-configuration t) +(gv-define-simple-setter default-file-modes set-default-file-modes t) +(gv-define-simple-setter documentation-property put) +(gv-define-setter face-background (x f &optional s) + `(set-face-background ,f ,x ,s)) +(gv-define-setter face-background-pixmap (x f &optional s) + `(set-face-background-pixmap ,f ,x ,s)) +(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) +(gv-define-setter face-foreground (x f &optional s) + `(set-face-foreground ,f ,x ,s)) +(gv-define-setter face-underline-p (x f &optional s) + `(set-face-underline ,f ,x ,s)) +(gv-define-simple-setter file-modes set-file-modes t) +(gv-define-simple-setter frame-height set-screen-height t) +(gv-define-simple-setter frame-parameters modify-frame-parameters t) +(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) +(gv-define-simple-setter frame-width set-screen-width t) +(gv-define-simple-setter getenv setenv t) +(gv-define-simple-setter get-register set-register) +(gv-define-simple-setter global-key-binding global-set-key) +(gv-define-simple-setter local-key-binding local-set-key) +(gv-define-simple-setter mark set-mark t) +(gv-define-simple-setter mark-marker set-mark t) +(gv-define-simple-setter marker-position set-marker t) +(gv-define-setter mouse-position (store scr) + `(set-mouse-position ,scr (car ,store) (cadr ,store) + (cddr ,store))) +(gv-define-simple-setter point goto-char) +(gv-define-simple-setter point-marker goto-char t) +(gv-define-setter point-max (store) + `(progn (narrow-to-region (point-min) ,store) ,store)) +(gv-define-setter point-min (store) + `(progn (narrow-to-region ,store (point-max)) ,store)) +(gv-define-setter read-mouse-position (store scr) + `(set-mouse-position ,scr (car ,store) (cdr ,store))) +(gv-define-simple-setter screen-height set-screen-height t) +(gv-define-simple-setter screen-width set-screen-width t) +(gv-define-simple-setter selected-window select-window) +(gv-define-simple-setter selected-screen select-screen) +(gv-define-simple-setter selected-frame select-frame) +(gv-define-simple-setter standard-case-table set-standard-case-table) +(gv-define-simple-setter syntax-table set-syntax-table) +(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) +(gv-define-setter window-height (store) + `(progn (enlarge-window (- ,store (window-height))) ,store)) +(gv-define-setter window-width (store) + `(progn (enlarge-window (- ,store (window-width)) t) ,store)) +(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) +(gv-define-simple-setter x-get-selection x-own-selection t) + +;; More complex setf-methods. + +;; This is a hack that allows (setf (eq a 7) B) to mean either +;; (setq a 7) or (setq a nil) depending on whether B is nil or not. +;; This is useful when you have control over the PLACE but not over +;; the VALUE, as is the case in define-minor-mode's :variable. +;; It turned out that :variable needed more flexibility anyway, so +;; this doesn't seem too useful now. +(gv-define-expander eq + (lambda (do place val) + (gv-letplace (getter setter) place + (macroexp-let2 nil val val + (funcall do `(eq ,getter ,val) + (lambda (v) + `(cond + (,v ,(funcall setter val)) + ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) + +(gv-define-expander substring + (lambda (do place from &optional to) + (gv-letplace (getter setter) place + (macroexp-let2 nil start from + (macroexp-let2 nil end to + (funcall do `(substring ,getter ,start ,end) + (lambda (v) + (funcall setter `(cl--set-substring + ,getter ,start ,end ,v))))))))) + +;;; Miscellaneous. + +;;;###autoload +(progn + ;; Make sure functions defined with cl-defsubst can be inlined even in + ;; packages which do not require CL. We don't put an autoload cookie + ;; directly on that function, since those cookies only go to cl-loaddefs. + (autoload 'cl--defsubst-expand "cl-macs") + ;; Autoload, so autoload.el and font-lock can use it even when CL + ;; is not loaded. + (put 'cl-defun 'doc-string-elt 3) + (put 'cl-defmacro 'doc-string-elt 3) + (put 'cl-defsubst 'doc-string-elt 3) + (put 'cl-defstruct 'doc-string-elt 2)) + +(load "cl-loaddefs" nil 'quiet) + +(provide 'cl-lib) + +;; Local variables: +;; byte-compile-dynamic: t +;; End: + +;;; cl-lib.el ends here diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 06977174432..4198c0e0063 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -3,23 +3,24 @@ ;;; Code: -;;;### (autoloads (cl-prettyexpand cl-macroexpand-all cl-remprop -;;;;;; cl-do-remf cl-set-getf getf get* tailp list-length nreconc -;;;;;; revappend concatenate subseq cl-float-limits random-state-p -;;;;;; make-random-state random* signum rem* mod* round* truncate* -;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p -;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively -;;;;;; notevery notany every some mapcon mapcan mapl maplist map -;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "2ad388f5b02cbddb80b7ed6724f5c7d1") +;;;### (autoloads (cl-prettyexpand cl-remprop cl--do-remf cl--set-getf +;;;;;; cl-getf cl-get cl-tailp cl-list-length cl-nreconc cl-revappend +;;;;;; cl-concatenate cl-subseq cl-float-limits cl-random-state-p +;;;;;; cl-make-random-state cl-random cl-signum cl-rem cl-mod cl-round +;;;;;; cl-truncate cl-ceiling cl-floor cl-isqrt cl-lcm cl-gcd cl--set-frame-visible-p +;;;;;; cl--map-overlays cl--map-intervals cl--map-keymap-recursively +;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan +;;;;;; cl-mapl cl-mapc cl-maplist cl-map cl--mapcar-many cl-equalp +;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "6c7926a10c377679687a2ab6a4d1c186") ;;; Generated autoloads from cl-extra.el -(autoload 'coerce "cl-extra" "\ +(autoload 'cl-coerce "cl-extra" "\ Coerce OBJECT to type TYPE. TYPE is a Common Lisp type specifier. \(fn OBJECT TYPE)" nil nil) -(autoload 'equalp "cl-extra" "\ +(autoload 'cl-equalp "cl-extra" "\ Return 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 @@ -27,213 +28,217 @@ strings case-insensitively. \(fn X Y)" nil nil) -(autoload 'cl-mapcar-many "cl-extra" "\ -Not documented +(autoload 'cl--mapcar-many "cl-extra" "\ + \(fn CL-FUNC CL-SEQS)" nil nil) -(autoload 'map "cl-extra" "\ +(autoload 'cl-map "cl-extra" "\ Map a FUNCTION across one or more SEQUENCEs, returning a sequence. TYPE is the sequence type to return. \(fn TYPE FUNCTION SEQUENCE...)" nil nil) -(autoload 'maplist "cl-extra" "\ +(autoload 'cl-maplist "cl-extra" "\ Map FUNCTION to each sublist of LIST or LISTs. -Like `mapcar', except applies to lists and their cdr's rather than to +Like `cl-mapcar', except applies to lists and their cdr's rather than to the elements themselves. \(fn FUNCTION LIST...)" nil nil) -(autoload 'mapl "cl-extra" "\ -Like `maplist', but does not accumulate values returned by the function. +(autoload 'cl-mapc "cl-extra" "\ +Like `cl-mapcar', but does not accumulate values returned by the function. + +\(fn FUNCTION SEQUENCE...)" nil nil) + +(autoload 'cl-mapl "cl-extra" "\ +Like `cl-maplist', but does not accumulate values returned by the function. \(fn FUNCTION LIST...)" nil nil) -(autoload 'mapcan "cl-extra" "\ -Like `mapcar', but nconc's together the values returned by the function. +(autoload 'cl-mapcan "cl-extra" "\ +Like `cl-mapcar', but nconc's together the values returned by the function. \(fn FUNCTION SEQUENCE...)" nil nil) -(autoload 'mapcon "cl-extra" "\ -Like `maplist', but nconc's together the values returned by the function. +(autoload 'cl-mapcon "cl-extra" "\ +Like `cl-maplist', but nconc's together the values returned by the function. \(fn FUNCTION LIST...)" nil nil) -(autoload 'some "cl-extra" "\ +(autoload 'cl-some "cl-extra" "\ Return true if PREDICATE is true of any element of SEQ or SEQs. If so, return the true (non-nil) value returned by PREDICATE. \(fn PREDICATE SEQ...)" nil nil) -(autoload 'every "cl-extra" "\ +(autoload 'cl-every "cl-extra" "\ Return true if PREDICATE is true of every element of SEQ or SEQs. \(fn PREDICATE SEQ...)" nil nil) -(autoload 'notany "cl-extra" "\ +(autoload 'cl-notany "cl-extra" "\ Return true if PREDICATE is false of every element of SEQ or SEQs. \(fn PREDICATE SEQ...)" nil nil) -(autoload 'notevery "cl-extra" "\ +(autoload 'cl-notevery "cl-extra" "\ Return true if PREDICATE is false of some element of SEQ or SEQs. \(fn PREDICATE SEQ...)" nil nil) -(defalias 'cl-map-keymap 'map-keymap) +(autoload 'cl--map-keymap-recursively "cl-extra" "\ -(autoload 'cl-map-keymap-recursively "cl-extra" "\ -Not documented \(fn CL-FUNC-REC CL-MAP &optional CL-BASE)" nil nil) -(autoload 'cl-map-intervals "cl-extra" "\ -Not documented +(autoload 'cl--map-intervals "cl-extra" "\ + \(fn CL-FUNC &optional CL-WHAT CL-PROP CL-START CL-END)" nil nil) -(autoload 'cl-map-overlays "cl-extra" "\ -Not documented +(autoload 'cl--map-overlays "cl-extra" "\ -\(fn CL-FUNC &optional CL-BUFFER CL-START CL-END CL-ARG)" nil nil) -(autoload 'cl-set-frame-visible-p "cl-extra" "\ -Not documented +\(fn CL-FUNC &optional CL-BUFFER CL-START CL-END CL-ARG)" nil nil) -\(fn FRAME VAL)" nil nil) +(autoload 'cl--set-frame-visible-p "cl-extra" "\ -(autoload 'cl-progv-before "cl-extra" "\ -Not documented -\(fn SYMS VALUES)" nil nil) +\(fn FRAME VAL)" nil nil) -(autoload 'gcd "cl-extra" "\ +(autoload 'cl-gcd "cl-extra" "\ Return the greatest common divisor of the arguments. \(fn &rest ARGS)" nil nil) -(autoload 'lcm "cl-extra" "\ +(autoload 'cl-lcm "cl-extra" "\ Return the least common multiple of the arguments. \(fn &rest ARGS)" nil nil) -(autoload 'isqrt "cl-extra" "\ +(autoload 'cl-isqrt "cl-extra" "\ Return the integer square root of the argument. \(fn X)" nil nil) -(autoload 'floor* "cl-extra" "\ +(autoload 'cl-floor "cl-extra" "\ Return a list of the floor of X and the fractional part of X. With two arguments, return floor and remainder of their quotient. \(fn X &optional Y)" nil nil) -(autoload 'ceiling* "cl-extra" "\ +(autoload 'cl-ceiling "cl-extra" "\ Return a list of the ceiling of X and the fractional part of X. With two arguments, return ceiling and remainder of their quotient. \(fn X &optional Y)" nil nil) -(autoload 'truncate* "cl-extra" "\ +(autoload 'cl-truncate "cl-extra" "\ 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. \(fn X &optional Y)" nil nil) -(autoload 'round* "cl-extra" "\ +(autoload 'cl-round "cl-extra" "\ Return a list of X rounded to the nearest integer and the remainder. With two arguments, return rounding and remainder of their quotient. \(fn X &optional Y)" nil nil) -(autoload 'mod* "cl-extra" "\ +(autoload 'cl-mod "cl-extra" "\ The remainder of X divided by Y, with the same sign as Y. \(fn X Y)" nil nil) -(autoload 'rem* "cl-extra" "\ +(autoload 'cl-rem "cl-extra" "\ The remainder of X divided by Y, with the same sign as X. \(fn X Y)" nil nil) -(autoload 'signum "cl-extra" "\ +(autoload 'cl-signum "cl-extra" "\ Return 1 if X is positive, -1 if negative, 0 if zero. \(fn X)" nil nil) -(autoload 'random* "cl-extra" "\ +(autoload 'cl-random "cl-extra" "\ Return a random nonnegative number less than LIM, an integer or float. Optional second arg STATE is a random-state object. \(fn LIM &optional STATE)" nil nil) -(autoload 'make-random-state "cl-extra" "\ -Return a copy of random-state STATE, or of `*random-state*' if omitted. +(autoload 'cl-make-random-state "cl-extra" "\ +Return a copy of random-state STATE, or of the internal state if omitted. If STATE is t, return a new state object seeded from the time of day. \(fn &optional STATE)" nil nil) -(autoload 'random-state-p "cl-extra" "\ +(autoload 'cl-random-state-p "cl-extra" "\ Return t if OBJECT is a random-state object. \(fn OBJECT)" nil nil) (autoload 'cl-float-limits "cl-extra" "\ -Not documented +Initialize the Common Lisp floating-point parameters. +This sets the values of: `cl-most-positive-float', `cl-most-negative-float', +`cl-least-positive-float', `cl-least-negative-float', `cl-float-epsilon', +`cl-float-negative-epsilon', `cl-least-positive-normalized-float', and +`cl-least-negative-normalized-float'. \(fn)" nil nil) -(autoload 'subseq "cl-extra" "\ +(autoload 'cl-subseq "cl-extra" "\ 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. \(fn SEQ START &optional END)" nil nil) -(autoload 'concatenate "cl-extra" "\ +(autoload 'cl-concatenate "cl-extra" "\ Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. \(fn TYPE SEQUENCE...)" nil nil) -(autoload 'revappend "cl-extra" "\ +(autoload 'cl-revappend "cl-extra" "\ Equivalent to (append (reverse X) Y). \(fn X Y)" nil nil) -(autoload 'nreconc "cl-extra" "\ +(autoload 'cl-nreconc "cl-extra" "\ Equivalent to (nconc (nreverse X) Y). \(fn X Y)" nil nil) -(autoload 'list-length "cl-extra" "\ +(autoload 'cl-list-length "cl-extra" "\ Return the length of list X. Return nil if list is circular. \(fn X)" nil nil) -(autoload 'tailp "cl-extra" "\ +(autoload 'cl-tailp "cl-extra" "\ Return true if SUBLIST is a tail of LIST. \(fn SUBLIST LIST)" nil nil) -(autoload 'get* "cl-extra" "\ +(autoload 'cl-get "cl-extra" "\ Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. \(fn SYMBOL PROPNAME &optional DEFAULT)" nil nil) -(autoload 'getf "cl-extra" "\ +(put 'cl-get 'compiler-macro #'cl--compiler-macro-get) + +(autoload 'cl-getf "cl-extra" "\ Search PROPLIST for property PROPNAME; return its value or DEFAULT. PROPLIST is a list of the sort returned by `symbol-plist'. \(fn PROPLIST PROPNAME &optional DEFAULT)" nil nil) -(autoload 'cl-set-getf "cl-extra" "\ -Not documented +(autoload 'cl--set-getf "cl-extra" "\ + \(fn PLIST TAG VAL)" nil nil) -(autoload 'cl-do-remf "cl-extra" "\ -Not documented +(autoload 'cl--do-remf "cl-extra" "\ + \(fn PLIST TAG)" nil nil) @@ -242,136 +247,146 @@ Remove from SYMBOL's plist the property PROPNAME and its value. \(fn SYMBOL PROPNAME)" nil nil) -(defalias 'remprop 'cl-remprop) - -(defalias 'cl-gethash 'gethash) - -(defalias 'cl-puthash 'puthash) - -(defalias 'cl-remhash 'remhash) - -(defalias 'cl-clrhash 'clrhash) - -(defalias 'cl-maphash 'maphash) +(autoload 'cl-prettyexpand "cl-extra" "\ +Expand macros in FORM and insert the pretty-printed result. +Optional argument FULL non-nil means to expand all macros, +including `cl-block' and `cl-eval-when'. -(defalias 'cl-make-hash-table 'make-hash-table) +\(fn FORM &optional FULL)" nil nil) -(defalias 'cl-hash-table-p 'hash-table-p) +;;;*** + +;;;### (autoloads (cl--compiler-macro-adjoin cl-defsubst cl-compiler-macroexpand +;;;;;; cl-define-compiler-macro cl-assert cl-check-type cl-typep +;;;;;; cl-deftype cl-defstruct cl-callf2 cl-callf cl-letf* cl-letf +;;;;;; cl-rotatef cl-shiftf cl-remf cl-psetf cl-declare cl-the cl-locally +;;;;;; cl-multiple-value-setq cl-multiple-value-bind cl-symbol-macrolet +;;;;;; cl-macrolet cl-labels cl-flet* cl-flet cl-progv cl-psetq +;;;;;; cl-do-all-symbols cl-do-symbols cl-dotimes cl-dolist cl-do* +;;;;;; cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase +;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when +;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp +;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*) +;;;;;; "cl-macs" "cl-macs.el" "ad8afd35d8d75f5f22e7547b02bac556") +;;; Generated autoloads from cl-macs.el -(defalias 'cl-hash-table-count 'hash-table-count) +(autoload 'cl--compiler-macro-list* "cl-macs" "\ -(autoload 'cl-macroexpand-all "cl-extra" "\ -Expand all macro calls through a Lisp FORM. -This also does some trivial optimizations to make the form prettier. -\(fn FORM &optional ENV)" nil nil) +\(fn FORM ARG &rest OTHERS)" nil nil) -(autoload 'cl-prettyexpand "cl-extra" "\ -Not documented +(autoload 'cl--compiler-macro-cXXr "cl-macs" "\ -\(fn FORM &optional FULL)" nil nil) -;;;*** - -;;;### (autoloads (defsubst* compiler-macroexpand define-compiler-macro -;;;;;; assert check-type typep deftype cl-struct-setf-expander defstruct -;;;;;; define-modify-macro callf2 callf letf* letf rotatef shiftf -;;;;;; remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method -;;;;;; declare the locally multiple-value-setq multiple-value-bind -;;;;;; lexical-let* lexical-let symbol-macrolet macrolet labels -;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist -;;;;;; do* do loop return-from return block etypecase typecase ecase -;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "42c2aedfe68e4adf341955223bcf31b9") -;;; Generated autoloads from cl-macs.el +\(fn FORM X)" nil nil) -(autoload 'gensym "cl-macs" "\ +(autoload 'cl-gensym "cl-macs" "\ Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\". \(fn &optional PREFIX)" nil nil) -(autoload 'gentemp "cl-macs" "\ +(autoload 'cl-gentemp "cl-macs" "\ Generate a new interned symbol with a unique name. The name is made by appending a number to PREFIX, default \"G\". \(fn &optional PREFIX)" nil nil) -(autoload 'defun* "cl-macs" "\ +(autoload 'cl-defun "cl-macs" "\ Define NAME as a function. Like normal `defun', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...). +and BODY is implicitly surrounded by (cl-block NAME ...). -\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) +\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil t) -(autoload 'defmacro* "cl-macs" "\ +(put 'cl-defun 'doc-string-elt '3) + +(put 'cl-defun 'lisp-indent-function '2) + +(autoload 'cl-defmacro "cl-macs" "\ Define NAME as a macro. Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...). +and BODY is implicitly surrounded by (cl-block NAME ...). + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil t) -\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) +(put 'cl-defmacro 'doc-string-elt '3) -(autoload 'function* "cl-macs" "\ +(put 'cl-defmacro 'lisp-indent-function '2) + +(autoload 'cl-function "cl-macs" "\ Introduce a function. Like normal `function', except that if argument is a lambda form, its argument list allows full Common Lisp conventions. -\(fn FUNC)" nil (quote macro)) +\(fn FUNC)" nil t) + +(autoload 'cl-destructuring-bind "cl-macs" "\ +Bind the variables in ARGS to the result of EXPR and execute BODY. -(autoload 'destructuring-bind "cl-macs" "\ -Not documented +\(fn ARGS EXPR &rest BODY)" nil t) -\(fn ARGS EXPR &rest BODY)" nil (quote macro)) +(put 'cl-destructuring-bind 'lisp-indent-function '2) -(autoload 'eval-when "cl-macs" "\ +(autoload 'cl-eval-when "cl-macs" "\ 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. -\(fn (WHEN...) BODY...)" nil (quote macro)) +\(fn (WHEN...) BODY...)" nil t) -(autoload 'load-time-value "cl-macs" "\ +(put 'cl-eval-when 'lisp-indent-function '1) + +(autoload 'cl-load-time-value "cl-macs" "\ Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant. -\(fn FORM &optional READ-ONLY)" nil (quote macro)) +\(fn FORM &optional READ-ONLY)" nil t) -(autoload 'case "cl-macs" "\ +(autoload 'cl-case "cl-macs" "\ Eval EXPR and choose among 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 +If no clause succeeds, cl-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'. -\(fn EXPR (KEYLIST BODY...)...)" nil (quote macro)) +\(fn EXPR (KEYLIST BODY...)...)" nil t) + +(put 'cl-case 'lisp-indent-function '1) -(autoload 'ecase "cl-macs" "\ -Like `case', but error if no case fits. +(autoload 'cl-ecase "cl-macs" "\ +Like `cl-case', but error if no case fits. `otherwise'-clauses are not allowed. -\(fn EXPR (KEYLIST BODY...)...)" nil (quote macro)) +\(fn EXPR (KEYLIST BODY...)...)" nil t) + +(put 'cl-ecase 'lisp-indent-function '1) -(autoload 'typecase "cl-macs" "\ +(autoload 'cl-typecase "cl-macs" "\ Evals EXPR, chooses among 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 +cl-typecase returns nil. A TYPE of t or `otherwise' is allowed only in the final clause, and matches if no other keys match. -\(fn EXPR (TYPE BODY...)...)" nil (quote macro)) +\(fn EXPR (TYPE BODY...)...)" nil t) -(autoload 'etypecase "cl-macs" "\ -Like `typecase', but error if no case fits. +(put 'cl-typecase 'lisp-indent-function '1) + +(autoload 'cl-etypecase "cl-macs" "\ +Like `cl-typecase', but error if no case fits. `otherwise'-clauses are not allowed. -\(fn EXPR (TYPE BODY...)...)" nil (quote macro)) +\(fn EXPR (TYPE BODY...)...)" nil t) + +(put 'cl-etypecase 'lisp-indent-function '1) -(autoload 'block "cl-macs" "\ +(autoload 'cl-block "cl-macs" "\ Define a lexically-scoped block named NAME. -NAME may be any symbol. Code inside the BODY forms can call `return-from' +NAME may be any symbol. Code inside the BODY forms can call `cl-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 @@ -379,24 +394,28 @@ dynamically scoped: Only references to it within BODY will work. These references may appear inside macro expansions, but not inside functions called from BODY. -\(fn NAME &rest BODY)" nil (quote macro)) +\(fn NAME &rest BODY)" nil t) -(autoload 'return "cl-macs" "\ +(put 'cl-block 'lisp-indent-function '1) + +(autoload 'cl-return "cl-macs" "\ Return from the block named nil. -This is equivalent to `(return-from nil RESULT)'. +This is equivalent to `(cl-return-from nil RESULT)'. -\(fn &optional RESULT)" nil (quote macro)) +\(fn &optional RESULT)" nil t) -(autoload 'return-from "cl-macs" "\ +(autoload 'cl-return-from "cl-macs" "\ Return from the block named NAME. -This jumps out to the innermost enclosing `(block NAME ...)' form, +This jumps out to the innermost enclosing `(cl-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. -\(fn NAME &optional RESULT)" nil (quote macro)) +\(fn NAME &optional RESULT)" nil t) + +(put 'cl-return-from 'lisp-indent-function '1) -(autoload 'loop "cl-macs" "\ +(autoload 'cl-loop "cl-macs" "\ The Common Lisp `loop' macro. Valid clauses are: for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, @@ -410,223 +429,194 @@ Valid clauses are: do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR, finally return EXPR, named NAME. -\(fn CLAUSE...)" nil (quote macro)) +\(fn CLAUSE...)" nil t) -(autoload 'do "cl-macs" "\ +(autoload 'cl-do "cl-macs" "\ The Common Lisp `do' loop. -\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil (quote macro)) +\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil t) + +(put 'cl-do 'lisp-indent-function '2) -(autoload 'do* "cl-macs" "\ +(autoload 'cl-do* "cl-macs" "\ The Common Lisp `do*' loop. -\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil (quote macro)) +\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil t) -(autoload 'dolist "cl-macs" "\ +(put 'cl-do* 'lisp-indent-function '2) + +(autoload 'cl-dolist "cl-macs" "\ 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. +An implicit nil block is established around the loop. + +\(fn (VAR LIST [RESULT]) BODY...)" nil t) -\(fn (VAR LIST [RESULT]) BODY...)" nil (quote macro)) +(put 'cl-dolist 'lisp-indent-function '1) -(autoload 'dotimes "cl-macs" "\ +(autoload 'cl-dotimes "cl-macs" "\ 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. -\(fn (VAR COUNT [RESULT]) BODY...)" nil (quote macro)) +\(fn (VAR COUNT [RESULT]) BODY...)" nil t) -(autoload 'do-symbols "cl-macs" "\ +(put 'cl-dotimes 'lisp-indent-function '1) + +(autoload 'cl-do-symbols "cl-macs" "\ Loop over all symbols. Evaluate BODY with VAR bound to each interned symbol, or to each symbol from OBARRAY. -\(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro)) +\(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil t) + +(put 'cl-do-symbols 'lisp-indent-function '1) + +(autoload 'cl-do-all-symbols "cl-macs" "\ +Like `cl-do-symbols', but use the default obarray. -(autoload 'do-all-symbols "cl-macs" "\ -Not documented +\(fn (VAR [RESULT]) BODY...)" nil t) -\(fn SPEC &rest BODY)" nil (quote macro)) +(put 'cl-do-all-symbols 'lisp-indent-function '1) -(autoload 'psetq "cl-macs" "\ +(autoload 'cl-psetq "cl-macs" "\ 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. -\(fn SYM VAL SYM VAL ...)" nil (quote macro)) +\(fn SYM VAL SYM VAL ...)" nil t) -(autoload 'progv "cl-macs" "\ +(autoload 'cl-progv "cl-macs" "\ Bind SYMBOLS to VALUES dynamically in BODY. The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. Each symbol in the first list is bound to the corresponding value in the -second list (or made unbound if VALUES is shorter than SYMBOLS); then the +second list (or to nil if VALUES is shorter than SYMBOLS); then the BODY forms are executed and their result is returned. This is much like a `let' form, except that the list of symbols can be computed at run-time. -\(fn SYMBOLS VALUES &rest BODY)" nil (quote macro)) +\(fn SYMBOLS VALUES &rest BODY)" nil t) + +(put 'cl-progv 'lisp-indent-function '2) + +(autoload 'cl-flet "cl-macs" "\ +Make local function definitions. +Like `cl-labels' but the definitions are not recursive. + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t) -(autoload 'flet "cl-macs" "\ -Make temporary function definitions. -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). +(put 'cl-flet 'lisp-indent-function '1) -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +(autoload 'cl-flet* "cl-macs" "\ +Make local function definitions. +Like `cl-flet' but the definitions can refer to previous ones. -(autoload 'labels "cl-macs" "\ +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t) + +(put 'cl-flet* 'lisp-indent-function '1) + +(autoload 'cl-labels "cl-macs" "\ Make temporary function bindings. -This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully compliant with the Common Lisp standard. +The bindings can be recursive and the scoping is lexical, but capturing them +in closures will only work if `lexical-binding' is in use. + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t) -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +(put 'cl-labels 'lisp-indent-function '1) -(autoload 'macrolet "cl-macs" "\ +(autoload 'cl-macrolet "cl-macs" "\ Make temporary macro definitions. -This is like `flet', but for macros instead of functions. +This is like `cl-flet', but for macros instead of functions. -\(fn ((NAME ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +\(fn ((NAME ARGLIST BODY...) ...) FORM...)" nil t) -(autoload 'symbol-macrolet "cl-macs" "\ +(put 'cl-macrolet 'lisp-indent-function '1) + +(autoload 'cl-symbol-macrolet "cl-macs" "\ Make symbol macro definitions. Within the body FORMs, references to the variable NAME will be replaced by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). -\(fn ((NAME EXPANSION) ...) FORM...)" nil (quote macro)) - -(autoload 'lexical-let "cl-macs" "\ -Like `let', but lexically scoped. -The main visible difference is that lambdas inside BODY will create -lexical closures as in Common Lisp. +\(fn ((NAME EXPANSION) ...) FORM...)" nil t) -\(fn VARLIST BODY)" nil (quote macro)) +(put 'cl-symbol-macrolet 'lisp-indent-function '1) -(autoload 'lexical-let* "cl-macs" "\ -Like `let*', but lexically scoped. -The main visible difference is that lambdas inside BODY, and in -successive bindings within VARLIST, will create lexical closures -as in Common Lisp. This is similar to the behavior of `let*' in -Common Lisp. - -\(fn VARLIST BODY)" nil (quote macro)) - -(autoload 'multiple-value-bind "cl-macs" "\ +(autoload 'cl-multiple-value-bind "cl-macs" "\ 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 +is analogous to the Common Lisp `cl-multiple-value-bind' macro, using lists to +simulate true multiple return values. For compatibility, (cl-values A B C) is a synonym for (list A B C). -\(fn (SYM...) FORM BODY)" nil (quote macro)) +\(fn (SYM...) FORM BODY)" nil t) + +(put 'cl-multiple-value-bind 'lisp-indent-function '2) -(autoload 'multiple-value-setq "cl-macs" "\ +(autoload 'cl-multiple-value-setq "cl-macs" "\ 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). - -\(fn (SYM...) FORM)" nil (quote macro)) - -(autoload 'locally "cl-macs" "\ -Not documented - -\(fn &rest BODY)" nil (quote macro)) - -(autoload 'the "cl-macs" "\ -Not documented - -\(fn TYPE FORM)" nil (quote macro)) - -(autoload 'declare "cl-macs" "\ -Not documented - -\(fn &rest SPECS)" nil (quote macro)) +`cl-multiple-value-setq' macro, using lists to simulate true multiple return +values. For compatibility, (cl-values A B C) is a synonym for (list A B C). -(autoload 'define-setf-method "cl-macs" "\ -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. +\(fn (SYM...) FORM)" nil t) -\(fn NAME ARGLIST BODY...)" nil (quote macro)) +(put 'cl-multiple-value-setq 'lisp-indent-function '1) -(autoload 'defsetf "cl-macs" "\ -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: +(autoload 'cl-locally "cl-macs" "\ +Equivalent to `progn'. - (defsetf aref aset) +\(fn &rest BODY)" nil t) -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: +(autoload 'cl-the "cl-macs" "\ +At present this ignores _TYPE and is simply equivalent to FORM. - (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v)) +\(fn TYPE FORM)" nil t) -\(fn NAME [FUNC | ARGLIST (STORE) BODY...])" nil (quote macro)) +(put 'cl-the 'lisp-indent-function '1) -(autoload 'get-setf-method "cl-macs" "\ -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'. +(autoload 'cl-declare "cl-macs" "\ +Declare SPECS about the current function while compiling. +For instance -\(fn PLACE &optional ENV)" nil nil) + (cl-declare (warn 0)) -(autoload 'setf "cl-macs" "\ -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. +will turn off byte-compile warnings in the function. +See Info node `(cl)Declarations' for details. -\(fn PLACE VAL PLACE VAL ...)" nil (quote macro)) +\(fn &rest SPECS)" nil t) -(autoload 'psetf "cl-macs" "\ +(autoload 'cl-psetf "cl-macs" "\ 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. -\(fn PLACE VAL PLACE VAL ...)" nil (quote macro)) +\(fn PLACE VAL PLACE VAL ...)" nil t) -(autoload 'cl-do-pop "cl-macs" "\ -Not documented - -\(fn PLACE)" nil nil) - -(autoload 'remf "cl-macs" "\ +(autoload 'cl-remf "cl-macs" "\ 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. -\(fn PLACE TAG)" nil (quote macro)) +\(fn PLACE TAG)" nil t) -(autoload 'shiftf "cl-macs" "\ +(autoload 'cl-shiftf "cl-macs" "\ Shift left among PLACEs. -Example: (shiftf A B C) sets A to B, B to C, and returns the old A. +Example: (cl-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'. -\(fn PLACE... VAL)" nil (quote macro)) +\(fn PLACE... VAL)" nil t) -(autoload 'rotatef "cl-macs" "\ +(autoload 'cl-rotatef "cl-macs" "\ Rotate left among PLACEs. -Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. +Example: (cl-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'. -\(fn PLACE...)" nil (quote macro)) +\(fn PLACE...)" nil t) -(autoload 'letf "cl-macs" "\ +(autoload 'cl-letf "cl-macs" "\ 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 @@ -636,41 +626,37 @@ 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. -\(fn ((PLACE VALUE) ...) BODY...)" nil (quote macro)) +\(fn ((PLACE VALUE) ...) BODY...)" nil t) + +(put 'cl-letf 'lisp-indent-function '1) -(autoload 'letf* "cl-macs" "\ +(autoload 'cl-letf* "cl-macs" "\ 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. +Like `cl-letf' but where the bindings are performed one at a time, +rather than all at the end (i.e. like `let*' rather than like `let'). -\(fn ((PLACE VALUE) ...) BODY...)" nil (quote macro)) +\(fn BINDINGS &rest BODY)" nil t) -(autoload 'callf "cl-macs" "\ +(put 'cl-letf* 'lisp-indent-function '1) + +(autoload 'cl-callf "cl-macs" "\ 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'. -\(fn FUNC PLACE ARGS...)" nil (quote macro)) +\(fn FUNC PLACE &rest ARGS)" nil t) -(autoload 'callf2 "cl-macs" "\ -Set PLACE to (FUNC ARG1 PLACE ARGS...). -Like `callf', but PLACE is the second argument of FUNC, not the first. +(put 'cl-callf 'lisp-indent-function '2) -\(fn FUNC ARG1 PLACE ARGS...)" nil (quote macro)) +(autoload 'cl-callf2 "cl-macs" "\ +Set PLACE to (FUNC ARG1 PLACE ARGS...). +Like `cl-callf', but PLACE is the second argument of FUNC, not the first. -(autoload 'define-modify-macro "cl-macs" "\ -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)) +) +\(fn FUNC ARG1 PLACE ARGS...)" nil t) -\(fn NAME ARGLIST FUNC &optional DOC)" nil (quote macro)) +(put 'cl-callf2 'lisp-indent-function '3) -(autoload 'defstruct "cl-macs" "\ +(autoload 'cl-defstruct "cl-macs" "\ Define a struct type. This macro defines a new data type called NAME that stores data in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME' @@ -678,49 +664,51 @@ copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'. You can use the accessors to set the corresponding slots, via `setf'. NAME may instead take the form (NAME OPTIONS...), where each -OPTION is either a single keyword or (KEYWORD VALUE). -See Info node `(cl)Structures' for a list of valid keywords. +OPTION is either a single keyword or (KEYWORD VALUE) where +KEYWORD can be one of :conc-name, :constructor, :copier, :predicate, +:type, :named, :initial-offset, :print-function, or :include. Each SLOT may instead take the form (SLOT SLOT-OPTS...), where SLOT-OPTS are keyword-value pairs for that slot. Currently, only one keyword is supported, `:read-only'. If this has a non-nil value, that slot cannot be set via `setf'. -\(fn NAME SLOTS...)" nil (quote macro)) +\(fn NAME SLOTS...)" nil t) -(autoload 'cl-struct-setf-expander "cl-macs" "\ -Not documented +(put 'cl-defstruct 'doc-string-elt '2) -\(fn X NAME ACCESSOR PRED-FORM POS)" nil nil) +(put 'cl-defstruct 'lisp-indent-function '1) -(autoload 'deftype "cl-macs" "\ +(autoload 'cl-deftype "cl-macs" "\ Define NAME as a new data type. -The type name can then be used in `typecase', `check-type', etc. +The type name can then be used in `cl-typecase', `cl-check-type', etc. + +\(fn NAME ARGLIST &rest BODY)" nil t) -\(fn NAME ARGLIST &rest BODY)" nil (quote macro)) +(put 'cl-deftype 'doc-string-elt '3) -(autoload 'typep "cl-macs" "\ +(autoload 'cl-typep "cl-macs" "\ Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier. \(fn OBJECT TYPE)" nil nil) -(autoload 'check-type "cl-macs" "\ +(autoload 'cl-check-type "cl-macs" "\ Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type. -\(fn FORM TYPE &optional STRING)" nil (quote macro)) +\(fn FORM TYPE &optional STRING)" nil t) -(autoload 'assert "cl-macs" "\ +(autoload 'cl-assert "cl-macs" "\ 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. -\(fn FORM &optional SHOW-ARGS STRING &rest ARGS)" nil (quote macro)) +\(fn FORM &optional SHOW-ARGS STRING &rest ARGS)" nil t) -(autoload 'define-compiler-macro "cl-macs" "\ +(autoload 'cl-define-compiler-macro "cl-macs" "\ 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 @@ -732,51 +720,63 @@ 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. -\(fn FUNC ARGS &rest BODY)" nil (quote macro)) +\(fn FUNC ARGS &rest BODY)" nil t) -(autoload 'compiler-macroexpand "cl-macs" "\ -Not documented +(autoload 'cl-compiler-macroexpand "cl-macs" "\ +Like `macroexpand', but for compiler macros. +Expands FORM repeatedly until no further expansion is possible. +Returns FORM unchanged if it has no compiler macro, or if it has a +macro that returns its `&whole' argument. \(fn FORM)" nil nil) -(autoload 'defsubst* "cl-macs" "\ +(autoload 'cl-defsubst "cl-macs" "\ 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 ...). +surrounded by (cl-block NAME ...). + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil t) + +(put 'cl-defsubst 'lisp-indent-function '2) + +(autoload 'cl--compiler-macro-adjoin "cl-macs" "\ -\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) + +\(fn FORM A LIST &rest KEYS)" nil nil) ;;;*** -;;;### (autoloads (tree-equal nsublis sublis nsubst-if-not nsubst-if -;;;;;; nsubst subst-if-not subst-if subsetp nset-exclusive-or set-exclusive-or -;;;;;; nset-difference set-difference nintersection intersection -;;;;;; nunion union rassoc-if-not rassoc-if rassoc* assoc-if-not -;;;;;; assoc-if assoc* cl-adjoin member-if-not member-if member* -;;;;;; merge stable-sort sort* search mismatch count-if-not count-if -;;;;;; count position-if-not position-if position find-if-not find-if -;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not -;;;;;; substitute-if substitute delete-duplicates remove-duplicates -;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove* -;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "3be8c58a761d2491b5afbf3f098c978b") +;;;### (autoloads (cl-tree-equal cl-nsublis cl-sublis cl-nsubst-if-not +;;;;;; cl-nsubst-if cl-nsubst cl-subst-if-not cl-subst-if cl-subsetp +;;;;;; cl-nset-exclusive-or cl-set-exclusive-or cl-nset-difference +;;;;;; cl-set-difference cl-nintersection cl-intersection cl-nunion +;;;;;; cl-union cl-rassoc-if-not cl-rassoc-if cl-rassoc cl-assoc-if-not +;;;;;; cl-assoc-if cl-assoc cl--adjoin cl-member-if-not cl-member-if +;;;;;; cl-member cl-merge cl-stable-sort cl-sort cl-search cl-mismatch +;;;;;; cl-count-if-not cl-count-if cl-count cl-position-if-not cl-position-if +;;;;;; cl-position cl-find-if-not cl-find-if cl-find cl-nsubstitute-if-not +;;;;;; cl-nsubstitute-if cl-nsubstitute cl-substitute-if-not cl-substitute-if +;;;;;; cl-substitute cl-delete-duplicates cl-remove-duplicates cl-delete-if-not +;;;;;; cl-delete-if cl-delete cl-remove-if-not cl-remove-if cl-remove +;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "5ce2761d9a21845a7f6a2da0e4543844") ;;; Generated autoloads from cl-seq.el -(autoload 'reduce "cl-seq" "\ +(autoload 'cl-reduce "cl-seq" "\ Reduce two-argument FUNCTION across SEQ. Keywords supported: :start :end :from-end :initial-value :key \(fn FUNCTION SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'fill "cl-seq" "\ +(autoload 'cl-fill "cl-seq" "\ Fill the elements of SEQ with ITEM. Keywords supported: :start :end \(fn SEQ ITEM [KEYWORD VALUE]...)" nil nil) -(autoload 'replace "cl-seq" "\ +(autoload 'cl-replace "cl-seq" "\ Replace the elements of SEQ1 with the elements of SEQ2. SEQ1 is destructively modified, then returned. @@ -784,7 +784,7 @@ Keywords supported: :start1 :end1 :start2 :end2 \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload 'remove* "cl-seq" "\ +(autoload 'cl-remove "cl-seq" "\ 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. @@ -793,7 +793,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'remove-if "cl-seq" "\ +(autoload 'cl-remove-if "cl-seq" "\ 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. @@ -802,7 +802,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'remove-if-not "cl-seq" "\ +(autoload 'cl-remove-if-not "cl-seq" "\ 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. @@ -811,7 +811,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'delete* "cl-seq" "\ +(autoload 'cl-delete "cl-seq" "\ Remove all occurrences of ITEM in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -819,7 +819,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'delete-if "cl-seq" "\ +(autoload 'cl-delete-if "cl-seq" "\ Remove all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -827,7 +827,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'delete-if-not "cl-seq" "\ +(autoload 'cl-delete-if-not "cl-seq" "\ Remove all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -835,21 +835,21 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'remove-duplicates "cl-seq" "\ +(autoload 'cl-remove-duplicates "cl-seq" "\ Return a copy of SEQ with all duplicate elements removed. Keywords supported: :test :test-not :key :start :end :from-end \(fn SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'delete-duplicates "cl-seq" "\ +(autoload 'cl-delete-duplicates "cl-seq" "\ Remove all duplicate elements from SEQ (destructively). Keywords supported: :test :test-not :key :start :end :from-end \(fn SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'substitute "cl-seq" "\ +(autoload 'cl-substitute "cl-seq" "\ 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. @@ -858,7 +858,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'substitute-if "cl-seq" "\ +(autoload 'cl-substitute-if "cl-seq" "\ 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. @@ -867,7 +867,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'substitute-if-not "cl-seq" "\ +(autoload 'cl-substitute-if-not "cl-seq" "\ 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. @@ -876,7 +876,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubstitute "cl-seq" "\ +(autoload 'cl-nsubstitute "cl-seq" "\ Substitute NEW for OLD in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -884,7 +884,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubstitute-if "cl-seq" "\ +(autoload 'cl-nsubstitute-if "cl-seq" "\ Substitute NEW for all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -892,7 +892,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubstitute-if-not "cl-seq" "\ +(autoload 'cl-nsubstitute-if-not "cl-seq" "\ Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -900,7 +900,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'find "cl-seq" "\ +(autoload 'cl-find "cl-seq" "\ Find the first occurrence of ITEM in SEQ. Return the matching ITEM, or nil if not found. @@ -908,7 +908,7 @@ Keywords supported: :test :test-not :key :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'find-if "cl-seq" "\ +(autoload 'cl-find-if "cl-seq" "\ Find the first item satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. @@ -916,7 +916,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'find-if-not "cl-seq" "\ +(autoload 'cl-find-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. @@ -924,7 +924,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'position "cl-seq" "\ +(autoload 'cl-position "cl-seq" "\ Find the first occurrence of ITEM in SEQ. Return the index of the matching item, or nil if not found. @@ -932,7 +932,7 @@ Keywords supported: :test :test-not :key :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'position-if "cl-seq" "\ +(autoload 'cl-position-if "cl-seq" "\ Find the first item satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. @@ -940,7 +940,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'position-if-not "cl-seq" "\ +(autoload 'cl-position-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. @@ -948,28 +948,28 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'count "cl-seq" "\ +(autoload 'cl-count "cl-seq" "\ Count the number of occurrences of ITEM in SEQ. Keywords supported: :test :test-not :key :start :end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'count-if "cl-seq" "\ +(autoload 'cl-count-if "cl-seq" "\ Count the number of items satisfying PREDICATE in SEQ. Keywords supported: :key :start :end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'count-if-not "cl-seq" "\ +(autoload 'cl-count-if-not "cl-seq" "\ Count the number of items not satisfying PREDICATE in SEQ. Keywords supported: :key :start :end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'mismatch "cl-seq" "\ +(autoload 'cl-mismatch "cl-seq" "\ 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 shorter sequence. @@ -978,7 +978,7 @@ Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload 'search "cl-seq" "\ +(autoload 'cl-search "cl-seq" "\ 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. @@ -987,7 +987,7 @@ Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload 'sort* "cl-seq" "\ +(autoload 'cl-sort "cl-seq" "\ Sort the argument SEQ according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. @@ -995,7 +995,7 @@ Keywords supported: :key \(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload 'stable-sort "cl-seq" "\ +(autoload 'cl-stable-sort "cl-seq" "\ Sort the argument SEQ stably according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. @@ -1003,7 +1003,7 @@ Keywords supported: :key \(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload 'merge "cl-seq" "\ +(autoload 'cl-merge "cl-seq" "\ 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 PREDICATE is a `less-than' predicate on the elements. @@ -1012,7 +1012,7 @@ Keywords supported: :key \(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload 'member* "cl-seq" "\ +(autoload 'cl-member "cl-seq" "\ Find the first occurrence of ITEM in LIST. Return the sublist of LIST whose car is ITEM. @@ -1020,7 +1020,9 @@ Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'member-if "cl-seq" "\ +(put 'cl-member 'compiler-macro #'cl--compiler-macro-member) + +(autoload 'cl-member-if "cl-seq" "\ Find the first item satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. @@ -1028,7 +1030,7 @@ Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'member-if-not "cl-seq" "\ +(autoload 'cl-member-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. @@ -1036,54 +1038,56 @@ Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'cl-adjoin "cl-seq" "\ -Not documented +(autoload 'cl--adjoin "cl-seq" "\ + \(fn CL-ITEM CL-LIST &rest CL-KEYS)" nil nil) -(autoload 'assoc* "cl-seq" "\ +(autoload 'cl-assoc "cl-seq" "\ Find the first item whose car matches ITEM in LIST. Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'assoc-if "cl-seq" "\ +(put 'cl-assoc 'compiler-macro #'cl--compiler-macro-assoc) + +(autoload 'cl-assoc-if "cl-seq" "\ Find the first item whose car satisfies PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'assoc-if-not "cl-seq" "\ +(autoload 'cl-assoc-if-not "cl-seq" "\ Find the first item whose car does not satisfy PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'rassoc* "cl-seq" "\ +(autoload 'cl-rassoc "cl-seq" "\ Find the first item whose cdr matches ITEM in LIST. Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'rassoc-if "cl-seq" "\ +(autoload 'cl-rassoc-if "cl-seq" "\ Find the first item whose cdr satisfies PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'rassoc-if-not "cl-seq" "\ +(autoload 'cl-rassoc-if-not "cl-seq" "\ Find the first item whose cdr does not satisfy PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'union "cl-seq" "\ +(autoload 'cl-union "cl-seq" "\ Combine LIST1 and LIST2 using a set-union operation. The resulting 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 @@ -1093,7 +1097,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'nunion "cl-seq" "\ +(autoload 'cl-nunion "cl-seq" "\ Combine LIST1 and LIST2 using a set-union operation. The resulting list contains all items that appear in either LIST1 or LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1103,7 +1107,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'intersection "cl-seq" "\ +(autoload 'cl-intersection "cl-seq" "\ Combine LIST1 and LIST2 using a set-intersection operation. The resulting 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 @@ -1113,7 +1117,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'nintersection "cl-seq" "\ +(autoload 'cl-nintersection "cl-seq" "\ Combine LIST1 and LIST2 using a set-intersection operation. The resulting list contains all items that appear in both LIST1 and LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1123,7 +1127,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'set-difference "cl-seq" "\ +(autoload 'cl-set-difference "cl-seq" "\ Combine LIST1 and LIST2 using a set-difference operation. The resulting 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 @@ -1133,7 +1137,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'nset-difference "cl-seq" "\ +(autoload 'cl-nset-difference "cl-seq" "\ Combine LIST1 and LIST2 using a set-difference operation. The resulting list contains all items that appear in LIST1 but not LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1143,7 +1147,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'set-exclusive-or "cl-seq" "\ +(autoload 'cl-set-exclusive-or "cl-seq" "\ Combine LIST1 and LIST2 using a set-exclusive-or operation. The resulting list contains all items appearing in exactly one of LIST1, LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1153,7 +1157,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'nset-exclusive-or "cl-seq" "\ +(autoload 'cl-nset-exclusive-or "cl-seq" "\ Combine LIST1 and LIST2 using a set-exclusive-or operation. The resulting list contains all items appearing in exactly one of LIST1, LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1163,7 +1167,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'subsetp "cl-seq" "\ +(autoload 'cl-subsetp "cl-seq" "\ Return true if LIST1 is a subset of LIST2. I.e., if every element of LIST1 also appears in LIST2. @@ -1171,7 +1175,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'subst-if "cl-seq" "\ +(autoload 'cl-subst-if "cl-seq" "\ Substitute NEW for elements matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all matching elements replaced by NEW. @@ -1179,7 +1183,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'subst-if-not "cl-seq" "\ +(autoload 'cl-subst-if-not "cl-seq" "\ Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all non-matching elements replaced by NEW. @@ -1187,7 +1191,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubst "cl-seq" "\ +(autoload 'cl-nsubst "cl-seq" "\ 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'). @@ -1196,7 +1200,7 @@ Keywords supported: :test :test-not :key \(fn NEW OLD TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubst-if "cl-seq" "\ +(autoload 'cl-nsubst-if "cl-seq" "\ Substitute NEW for elements matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). @@ -1204,7 +1208,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubst-if-not "cl-seq" "\ +(autoload 'cl-nsubst-if-not "cl-seq" "\ 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'). @@ -1212,7 +1216,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'sublis "cl-seq" "\ +(autoload 'cl-sublis "cl-seq" "\ Perform substitutions indicated by ALIST in TREE (non-destructively). Return a copy of TREE with all matching elements replaced. @@ -1220,7 +1224,7 @@ Keywords supported: :test :test-not :key \(fn ALIST TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'nsublis "cl-seq" "\ +(autoload 'cl-nsublis "cl-seq" "\ Perform substitutions indicated by ALIST in TREE (destructively). Any matching element of TREE is changed via a call to `setcar'. @@ -1228,7 +1232,7 @@ Keywords supported: :test :test-not :key \(fn ALIST TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'tree-equal "cl-seq" "\ +(autoload 'cl-tree-equal "cl-seq" "\ Return t if trees TREE1 and TREE2 have `eql' leaves. Atoms are compared by `eql'; cons cells are compared recursively. @@ -1242,7 +1246,6 @@ Keywords supported: :test :test-not :key ;; version-control: never ;; no-byte-compile: t ;; no-update-autoloads: t +;; coding: utf-8 ;; End: - -;; arch-tag: 08cc5aab-e992-47f6-992e-12a7428c1a0e ;;; cl-loaddefs.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index fff99520be1..ab474ebb0db 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,11 +1,11 @@ -;;; cl-macs.el --- Common Lisp macros +;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t; coding: utf-8 -*- -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -43,231 +43,220 @@ ;;; Code: -(require 'cl) +(require 'cl-lib) +(require 'macroexp) +;; `gv' is required here because cl-macs can be loaded before loaddefs.el. +(require 'gv) (defmacro cl-pop2 (place) - (list 'prog1 (list 'car (list 'cdr place)) - (list 'setq place (list 'cdr (list 'cdr place))))) -(put 'cl-pop2 'edebug-form-spec 'edebug-sexps) + (declare (debug edebug-sexps)) + `(prog1 (car (cdr ,place)) + (setq ,place (cdr (cdr ,place))))) (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 '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) +;; Place compiler macros at the beginning, otherwise uses of the corresponding +;; functions can lead to recursive-loads that prevent the calls from +;; being optimized. -;;; Some predicates for analyzing Lisp forms. These are used by various -;;; macro expanders to optimize the results in certain common cases. +;;;###autoload +(defun cl--compiler-macro-list* (_form arg &rest others) + (let* ((args (reverse (cons arg others))) + (form (car args))) + (while (setq args (cdr args)) + (setq form `(cons ,(car args) ,form))) + form)) -(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max +;;;###autoload +(defun cl--compiler-macro-cXXr (form x) + (let* ((head (car form)) + (n (symbol-name (car form))) + (i (- (length n) 2))) + (if (not (string-match "c[ad]+r\\'" n)) + (if (and (fboundp head) (symbolp (symbol-function head))) + (cl--compiler-macro-cXXr (cons (symbol-function head) (cdr form)) + x) + (error "Compiler macro for cXXr applied to non-cXXr form")) + (while (> i (match-beginning 0)) + (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x)) + (setq i (1- i))) + x))) + +;;; 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 +(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) +(defun cl--simple-expr-p (x &optional size) + "Check if no side effects, and executes quickly." (or size (setq size 10)) - (if (and (consp x) (not (memq (car x) '(quote function function*)))) + (if (and (consp x) (not (memq (car x) '(quote function cl-function)))) (and (symbolp (car x)) - (or (memq (car x) cl-simple-funcs) + (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)))) + (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))) +(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*))))) +(defun cl--safe-expr-p (x) + "Check if no side effects." + (or (not (and (consp x) (not (memq (car x) '(quote function cl-function))))) (and (symbolp (car x)) - (or (memq (car x) cl-simple-funcs) - (memq (car x) cl-safe-funcs) + (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)))) + (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) +(defun cl--const-expr-p (x) (cond ((consp x) (or (eq (car x) 'quote) - (and (memq (car x) '(function function*)) + (and (memq (car x) '(function cl-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))))) +(defun cl--const-expr-val (x) + (and (macroexp-const-p x) (if (consp x) (nth 1 x) x))) -;;; Count number of times X refers to Y. Return nil for 0 times. -(defun cl-expr-contains (x y) +(defun cl--expr-contains (x y) + "Count number of times X refers to Y. Return nil for 0 times." + ;; FIXME: This is naive, and it will cl-count Y as referred twice in + ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on + ;; non-macroexpanded code, so it may also miss some occurrences that would + ;; only appear in the expanded code. (cond ((equal y x) 1) - ((and (consp x) (not (memq (car-safe x) '(quote function function*)))) + ((and (consp x) (not (memq (car x) '(quote function cl-function)))) (let ((sum 0)) - (while x - (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))) + (while (consp x) + (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0)))) + (setq sum (+ sum (or (cl--expr-contains 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)))) (pop y)) +(defun cl--expr-contains-any (x y) + (while (and y (not (cl--expr-contains x (car y)))) (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)))) +(defun cl--expr-depends-p (x y) + "Check whether X may depend on any of the symbols in Y." + (and (not (macroexp-const-p x)) + (or (not (cl--safe-expr-p x)) (cl--expr-contains-any x y)))) ;;; Symbols. -(defvar *gensym-counter*) +(defvar cl--gensym-counter) ;;;###autoload -(defun gensym (&optional prefix) +(defun cl-gensym (&optional prefix) "Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\"." (let ((pfix (if (stringp prefix) prefix "G")) (num (if (integerp prefix) prefix - (prog1 *gensym-counter* - (setq *gensym-counter* (1+ *gensym-counter*)))))) + (prog1 cl--gensym-counter + (setq cl--gensym-counter (1+ cl--gensym-counter)))))) (make-symbol (format "%s%d" pfix num)))) ;;;###autoload -(defun gentemp (&optional prefix) +(defun cl-gentemp (&optional prefix) "Generate a new interned symbol with a unique name. The name is made by appending a number to PREFIX, default \"G\"." (let ((pfix (if (stringp prefix) prefix "G")) name) - (while (intern-soft (setq name (format "%s%d" pfix *gensym-counter*))) - (setq *gensym-counter* (1+ *gensym-counter*))) + (while (intern-soft (setq name (format "%s%d" pfix cl--gensym-counter))) + (setq cl--gensym-counter (1+ cl--gensym-counter))) (intern name))) ;;; Program structure. -;;;###autoload -(defmacro defun* (name args &rest body) - "Define NAME as a function. -Like normal `defun', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...). +(def-edebug-spec cl-declarations + (&rest ("cl-declare" &rest sexp))) -\(fn NAME ARGLIST [DOCSTRING] BODY...)" - (let* ((res (cl-transform-lambda (cons args body) name)) - (form (list* 'defun name (cdr res)))) - (if (car res) (list 'progn (car res) form) form))) +(def-edebug-spec cl-declarations-or-string + (&or stringp cl-declarations)) -;;;###autoload -(defmacro defmacro* (name args &rest body) - "Define NAME as a macro. -Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...). +(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-keys"]] + [&optional ["&aux" &rest + &or (symbolp &optional def-form) symbolp]] + ))) -\(fn NAME ARGLIST [DOCSTRING] BODY...)" - (let* ((res (cl-transform-lambda (cons args body) name)) - (form (list* 'defmacro name (cdr res)))) - (if (car res) (list 'progn (car res) form) form))) +(def-edebug-spec cl-&optional-arg + (&or (arg &optional def-form arg) arg)) -;;;###autoload -(defmacro function* (func) - "Introduce a function. -Like normal `function', except that if argument is a lambda form, -its argument list 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)) +(def-edebug-spec cl-&key-arg + (&or ([&or (symbolp arg) arg] &optional def-form arg) arg)) -(defvar cl-macro-environment nil - "Keep the list of currently active macros. -It is a list of elements of the form either: -- (SYMBOL . FUNCTION) where FUNCTION is the macro expansion function. -- (SYMBOL-NAME . EXPANSION) where SYMBOL-NAME is the name of a symbol macro.") -(defvar bind-block) (defvar bind-defs) (defvar bind-enquote) -(defvar bind-inits) (defvar bind-lets) (defvar bind-forms) +(defconst cl--lambda-list-keywords + '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) -(declare-function help-add-fundoc-usage "help-fns" (docstring arglist)) +(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) +(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms) -(defun cl-transform-lambda (form bind-block) +(defun cl--transform-lambda (form bind-block) + "Transform a function form FORM of name BIND-BLOCK. +BIND-BLOCK is the name of the symbol to which the function will be bound, +and which will be used for the name of the `cl-block' surrounding the +function's body. +FORM is of the form (ARGS . BODY)." (let* ((args (car form)) (body (cdr form)) (orig-args args) - (bind-defs nil) (bind-enquote nil) - (bind-inits nil) (bind-lets nil) (bind-forms nil) + (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) + (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) (header nil) (simple-args nil)) (while (or (stringp (car body)) - (memq (car-safe (car body)) '(interactive declare))) + (memq (car-safe (car body)) '(interactive declare cl-declare))) (push (pop body) header)) - (setq args (if (listp args) (copy-list args) (list '&rest args))) + (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (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)) + (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) + (setq args (delq '&cl-defs (delq cl--bind-defs args)) + cl--bind-defs (cadr cl--bind-defs))) + (if (setq cl--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))) + (let* ((p (memq '&environment args)) (v (cadr p)) + (env-exp 'macroexpand-all-environment)) (if p (setq args (nconc (delq (car p) (delq v args)) - (list '&aux (list v 'cl-macro-environment)))))) + (list '&aux (list v env-exp)))))) (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)))))) + (or cl--bind-defs (consp (cadr args)))))) (push (pop args) simple-args)) - (or (eq bind-block 'cl-none) - (setq body (list (list* 'block bind-block body)))) + (or (eq cl--bind-block 'cl-none) + (setq body (list `(cl-block ,cl--bind-block ,@body)))) (if (null args) - (list* nil (nreverse simple-args) (nconc (nreverse header) body)) + (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) (if (memq '&optional simple-args) (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))) + (cl--do-arglist args nil (- (length simple-args) + (if (memq '&optional simple-args) 1 0))) + (setq cl--bind-lets (nreverse cl--bind-lets)) + (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) + ,@(nreverse cl--bind-inits))) (nconc (nreverse simple-args) - (list '&rest (car (pop bind-lets)))) + (list '&rest (car (pop cl--bind-lets)))) (nconc (let ((hdr (nreverse header))) ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not @@ -276,239 +265,383 @@ It is a list of elements of the form either: (require 'help-fns) (cons (help-add-fundoc-usage (if (stringp (car hdr)) (pop hdr)) - ;; orig-args can contain &cl-defs (an internal - ;; CL thingy I don't understand), so remove it. - (let ((x (memq '&cl-defs orig-args))) - (if (null x) orig-args - (delq (car x) (remq (cadr x) orig-args))))) + (format "%S" + (cons 'fn + (cl--make-usage-args orig-args)))) hdr))) - (list (nconc (list 'let* bind-lets) - (nreverse bind-forms) body))))))) + (list `(let* ,cl--bind-lets + ,@(nreverse cl--bind-forms) + ,@body))))))) -(defun cl-do-arglist (args expr &optional num) ; uses bind-* +;;;###autoload +(defmacro cl-defun (name args &rest body) + "Define NAME as a function. +Like normal `defun', except ARGLIST allows full Common Lisp conventions, +and BODY is implicitly surrounded by (cl-block NAME ...). + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug + ;; 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)) + (doc-string 3) + (indent 2)) + (let* ((res (cl--transform-lambda (cons args body) name)) + (form `(defun ,name ,@(cdr res)))) + (if (car res) `(progn ,(car res) ,form) form))) + +;; 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-keys"]] + [&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-keys"]] + [&optional ["&aux" &rest + &or (symbolp &optional def-form) symbolp]] + . [&or arg nil]))) + +;;;###autoload +(defmacro cl-defmacro (name args &rest body) + "Define NAME as a macro. +Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, +and BODY is implicitly surrounded by (cl-block NAME ...). + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug + (&define name cl-macro-list cl-declarations-or-string def-body)) + (doc-string 3) + (indent 2)) + (let* ((res (cl--transform-lambda (cons args body) name)) + (form `(defmacro ,name ,@(cdr res)))) + (if (car res) `(progn ,(car res) ,form) form))) + +(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 cl-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) + ("cl-function" cl-function) + form)) + +;;;###autoload +(defmacro cl-function (func) + "Introduce a function. +Like normal `function', except that if argument is a lambda form, +its argument list allows full Common Lisp conventions." + (declare (debug (&or symbolp cl-lambda-expr))) + (if (eq (car-safe func) 'lambda) + (let* ((res (cl--transform-lambda (cdr func) 'cl-none)) + (form `(function (lambda . ,(cdr res))))) + (if (car res) `(progn ,(car res) ,form) form)) + `(function ,func))) + +(declare-function help-add-fundoc-usage "help-fns" (docstring arglist)) + +(defun cl--make-usage-var (x) + "X can be a var or a (destructuring) lambda-list." + (cond + ((symbolp x) (make-symbol (upcase (symbol-name x)))) + ((consp x) (cl--make-usage-args x)) + (t x))) + +(defun cl--make-usage-args (arglist) + (if (cdr-safe (last arglist)) ;Not a proper list. + (let* ((last (last arglist)) + (tail (cdr last))) + (unwind-protect + (progn + (setcdr last nil) + (nconc (cl--make-usage-args arglist) (cl--make-usage-var tail))) + (setcdr last tail))) + ;; `orig-args' can contain &cl-defs (an internal + ;; CL thingy I don't understand), so remove it. + (let ((x (memq '&cl-defs arglist))) + (when x (setq arglist (delq (car x) (remq (cadr x) arglist))))) + (let ((state nil)) + (mapcar (lambda (x) + (cond + ((symbolp x) + (let ((first (aref (symbol-name x) 0))) + (if (eq ?\& first) + (setq state x) + ;; Strip a leading underscore, since it only + ;; means that this argument is unused. + (make-symbol (upcase (if (eq ?_ first) + (substring (symbol-name x) 1) + (symbol-name x))))))) + ((not (consp x)) x) + ((memq state '(nil &rest)) (cl--make-usage-args x)) + (t ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR). + (cl-list* + (if (and (consp (car x)) (eq state '&key)) + (list (caar x) (cl--make-usage-var (nth 1 (car x)))) + (cl--make-usage-var (car x))) + (nth 1 x) ;INITFORM. + (cl--make-usage-args (nthcdr 2 x)) ;SVAR. + )))) + arglist)))) + +(defun cl--do-arglist (args expr &optional num) ; uses bind-* (if (nlistp args) - (if (or (memq args lambda-list-keywords) (not (symbolp args))) + (if (or (memq args cl--lambda-list-keywords) (not (symbolp args))) (error "Invalid argument name: %s" args) - (push (list args expr) bind-lets)) - (setq args (copy-list args)) + (push (list args expr) cl--bind-lets)) + (setq args (cl-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)) + (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 (make-symbol "--cl-rest--")) (setq restarg (cadr restarg))) - (push (list restarg expr) bind-lets) + (push (list restarg expr) cl--bind-lets) (if (eq (car args) '&whole) - (push (list (cl-pop2 args) restarg) bind-lets)) + (push (list (cl-pop2 args) restarg) cl--bind-lets)) (let ((p args)) (setq minarg restarg) - (while (and p (not (memq (car p) lambda-list-keywords))) + (while (and p (not (memq (car p) cl--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))) + (setq minarg `(= (length ,restarg) + ,(length (cl-ldiff args p))) exactarg (not (eq args p))))) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) restarg))) - (cl-do-arglist + (cl--do-arglist (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))))))) + `(if ,minarg ,poparg + (signal 'wrong-number-of-arguments + (list ,(and (not (eq cl--bind-block 'cl-none)) + `',cl--bind-block) + (length ,restarg))))))) (setq num (1+ num) laterarg t)) (while (and (eq (car args) '&optional) (pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) - (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t))) + (if (cddr arg) (cl--do-arglist (nth 2 arg) `(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)) + (or (car cl--bind-defs) + (nth 1 (assq (car arg) cl--bind-defs))))) + (poparg `(pop ,restarg))) + (and def cl--bind-enquote (setq def `',def)) + (cl--do-arglist (car arg) + (if def `(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))) + (if (consp arg) (cl--do-arglist arg restarg))) (or (eq (car args) '&key) (= safety 0) exactarg - (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))) + (push `(if ,restarg + (signal 'wrong-number-of-arguments + (list + ,(and (not (eq cl--bind-block 'cl-none)) + `',cl--bind-block) + (+ ,num (length ,restarg))))) + cl--bind-forms))) (while (and (eq (car args) '&key) (pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) (let ((arg (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))) + (let ((name (symbol-name (car arg)))) + ;; Strip a leading underscore, since it only + ;; means that this argument is unused, but + ;; shouldn't affect the key's name (bug#12367). + (if (eq ?_ (aref name 0)) + (setq name (substring name 1))) + (intern (format ":%s" name))))) + (varg (if (consp (car arg)) (cl-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))) + (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs))))) + (look `(memq ',karg ,restarg))) + (and def cl--bind-enquote (setq def `',def)) (if (cddr arg) (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--"))) - (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 + (val `(car (cdr ,temp)))) + (cl--do-arglist temp look) + (cl--do-arglist varg + `(if ,temp + (prog1 ,val (setq ,temp t)) + ,def))) + (cl--do-arglist varg - (list 'car - (list 'cdr - (if (null def) + `(car (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)))))))) + `(or ,look + ,(if (eq (cl--const-expr-p def) t) + `'(nil ,(cl--const-expr-val def)) + `(list nil ,def)))))))) (push karg keys))))) (setq keys (nreverse keys)) (or (and (eq (car args) '&allow-other-keys) (pop args)) (null keys) (= safety 0) (let* ((var (make-symbol "--cl-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))))))) - (push (list 'let (list (list var restarg)) check) bind-forms))) + (check `(while ,var + (cond + ((memq (car ,var) ',(append keys allow)) + (setq ,var (cdr (cdr ,var)))) + ((car (cdr (memq (quote ,@allow) ,restarg))) + (setq ,var nil)) + (t + (error + ,(format "Keyword argument %%s not one of %s" + keys) + (car ,var))))))) + (push `(let ((,var ,restarg)) ,check) cl--bind-forms))) (while (and (eq (car args) '&aux) (pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) (if (consp (car args)) - (if (and bind-enquote (cadar args)) - (cl-do-arglist (caar args) - (list 'quote (cadr (pop args)))) - (cl-do-arglist (caar args) (cadr (pop args)))) - (cl-do-arglist (pop args) nil)))) + (if (and cl--bind-enquote (cl-cadar args)) + (cl--do-arglist (caar args) + `',(cadr (pop args))) + (cl--do-arglist (caar args) (cadr (pop args)))) + (cl--do-arglist (pop args) nil)))) (if args (error "Malformed argument list %s" save-args))))) -(defun cl-arglist-args (args) +(defun cl--arglist-args (args) (if (nlistp args) (list args) (let ((res nil) (kind nil) arg) (while (consp args) (setq arg (pop args)) - (if (memq arg lambda-list-keywords) (setq kind arg) + (if (memq arg cl--lambda-list-keywords) (setq kind arg) (if (eq arg '&cl-defs) (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)))))) + (setq res (nconc res (cl--arglist-args arg)))))) (nconc res (and args (list args)))))) ;;;###autoload -(defmacro destructuring-bind (args expr &rest body) - (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil) - (bind-defs nil) (bind-block 'cl-none) (bind-enquote nil)) - (cl-do-arglist (or args '(&aux)) expr) - (append '(progn) bind-inits - (list (nconc (list 'let* (nreverse bind-lets)) - (nreverse bind-forms) body))))) +(defmacro cl-destructuring-bind (args expr &rest body) + "Bind the variables in ARGS to the result of EXPR and execute BODY." + (declare (indent 2) + (debug (&define cl-macro-list def-form cl-declarations def-body))) + (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-inits nil) + (cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil)) + (cl--do-arglist (or args '(&aux)) expr) + (append '(progn) cl--bind-inits + (list `(let* ,(nreverse cl--bind-lets) + ,@(nreverse cl--bind-forms) ,@body))))) -;;; The `eval-when' form. +;;; The `cl-eval-when' form. (defvar cl-not-toplevel nil) ;;;###autoload -(defmacro eval-when (when &rest body) +(defmacro cl-eval-when (when &rest 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. \(fn (WHEN...) BODY...)" - (if (and (fboundp 'cl-compiling-file) (cl-compiling-file) + (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body))) + (if (and (fboundp 'cl--compiling-file) (cl--compiling-file) (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge (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)) + (if comp (cons 'progn (mapcar 'cl--compile-time-too body)) + `(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) +(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)))) + form (cons '(cl-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) + (cons 'progn (mapcar 'cl--compile-time-too (cdr form)))) + ((eq (car-safe form) 'cl-eval-when) (let ((when (nth 1 form))) (if (or (memq 'eval when) (memq :execute when)) - (list* 'eval-when (cons 'compile when) (cddr form)) + `(cl-eval-when (compile ,@when) ,@(cddr form)) form))) (t (eval form) form))) ;;;###autoload -(defmacro load-time-value (form &optional read-only) +(defmacro cl-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))) + (declare (debug (form &optional sexp))) + (if (cl--compiling-file) + (let* ((temp (cl-gentemp "--cl-load-time--")) + (set `(set ',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 'bytecomp-outbuffer))) - (list 'symbol-value (list 'quote temp))) - (list 'quote (eval form)))) + `(lambda (form) + (fset 'byte-compile-file-form + ',(symbol-function 'byte-compile-file-form)) + (byte-compile-file-form ',set) + (byte-compile-file-form form))) + (print set (symbol-value 'byte-compile--outbuffer))) + `(symbol-value ',temp)) + `',(eval form))) ;;; Conditional control structures. ;;;###autoload -(defmacro case (expr &rest clauses) +(defmacro cl-case (expr &rest clauses) "Eval EXPR and choose among 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 +If no clause succeeds, cl-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'. \n(fn EXPR (KEYLIST BODY...)...)" - (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) + (declare (indent 1) (debug (form &rest (sexp body)))) + (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (head-list nil) (body (cons 'cond @@ -516,39 +649,42 @@ Key values are compared by `eql'. (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)))) + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-ecase failed: %s, %s" + ,temp ',(reverse head-list))) ((listp (car c)) (setq head-list (append (car c) head-list)) - (list 'member* temp (list 'quote (car c)))) + `(cl-member ,temp ',(car c))) (t (if (memq (car c) head-list) (error "Duplicate key in case: %s" (car c))) (push (car c) head-list) - (list 'eql temp (list 'quote (car c))))) + `(eql ,temp ',(car c)))) (or (cdr c) '(nil))))) clauses)))) (if (eq temp expr) body - (list 'let (list (list temp expr)) body)))) + `(let ((,temp ,expr)) ,body)))) ;;;###autoload -(defmacro ecase (expr &rest clauses) - "Like `case', but error if no case fits. +(defmacro cl-ecase (expr &rest clauses) + "Like `cl-case', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (KEYLIST BODY...)...)" - (list* 'case expr (append clauses '((ecase-error-flag))))) + (declare (indent 1) (debug cl-case)) + `(cl-case ,expr ,@clauses (cl--ecase-error-flag))) ;;;###autoload -(defmacro typecase (expr &rest clauses) +(defmacro cl-typecase (expr &rest clauses) "Evals EXPR, chooses among 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 +cl-typecase returns nil. A TYPE of t or `otherwise' is allowed only in the final clause, and matches if no other keys match. \n(fn EXPR (TYPE BODY...)...)" - (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) + (declare (indent 1) + (debug (form &rest ([&or cl-type-spec "otherwise"] body)))) + (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (type-list nil) (body (cons 'cond @@ -556,91 +692,75 @@ final clause, and matches if no other keys match. (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)))) + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-etypecase failed: %s, %s" + ,temp ',(reverse type-list))) (t (push (car c) type-list) - (cl-make-type-test temp (car c)))) + (cl--make-type-test temp (car c)))) (or (cdr c) '(nil))))) clauses)))) (if (eq temp expr) body - (list 'let (list (list temp expr)) body)))) + `(let ((,temp ,expr)) ,body)))) ;;;###autoload -(defmacro etypecase (expr &rest clauses) - "Like `typecase', but error if no case fits. +(defmacro cl-etypecase (expr &rest clauses) + "Like `cl-typecase', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (TYPE BODY...)...)" - (list* 'typecase expr (append clauses '((ecase-error-flag))))) + (declare (indent 1) (debug cl-typecase)) + `(cl-typecase ,expr ,@clauses (cl--ecase-error-flag))) ;;; Blocks and exits. ;;;###autoload -(defmacro block (name &rest body) +(defmacro cl-block (name &rest body) "Define a lexically-scoped block named NAME. -NAME may be any symbol. Code inside the BODY forms can call `return-from' +NAME may be any symbol. Code inside the BODY forms can call `cl-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)))) + (declare (indent 1) (debug (symbolp body))) + (if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body) + `(cl--block-wrapper + (catch ',(intern (format "--cl-block-%s--" name)) + ,@body)))) ;;;###autoload -(defmacro return (&optional result) +(defmacro cl-return (&optional result) "Return from the block named nil. -This is equivalent to `(return-from nil RESULT)'." - (list 'return-from nil result)) +This is equivalent to `(cl-return-from nil RESULT)'." + (declare (debug (&optional form))) + `(cl-return-from nil ,result)) ;;;###autoload -(defmacro return-from (name &optional result) +(defmacro cl-return-from (name &optional result) "Return from the block named NAME. -This jumps out to the innermost enclosing `(block NAME ...)' form, +This jumps out to the innermost enclosing `(cl-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." + (declare (indent 1) (debug (symbolp &optional form))) (let ((name2 (intern (format "--cl-block-%s--" name)))) - (list 'cl-block-throw (list 'quote name2) result))) + `(cl--block-throw ',name2 ,result))) -;;; The "loop" macro. +;;; The "cl-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) +(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) +(defvar cl--loop-bindings) (defvar cl--loop-body) (defvar cl--loop-destr-temps) +(defvar cl--loop-finally) (defvar cl--loop-finish-flag) +(defvar cl--loop-first-flag) +(defvar cl--loop-initially) (defvar cl--loop-map-form) (defvar cl--loop-name) +(defvar cl--loop-result) (defvar cl--loop-result-explicit) +(defvar cl--loop-result-var) (defvar cl--loop-steps) (defvar cl--loop-symbol-macs) ;;;###autoload -(defmacro loop (&rest args) +(defmacro cl-loop (&rest loop-args) "The Common Lisp `loop' macro. Valid clauses are: for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, @@ -655,119 +775,286 @@ Valid clauses are: finally return EXPR, named NAME. \(fn CLAUSE...)" - (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 - (push `((,loop-finish-flag t)) loop-bindings)) - (if loop-first-flag - (progn (push `((,loop-first-flag t)) loop-bindings) - (push `(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))) + (declare (debug (&rest &or + ;; These are usually followed by a symbol, but it can + ;; actually be any destructuring-bind pattern, which + ;; would erroneously match `form'. + [[&or "for" "as" "with" "and"] sexp] + ;; These are followed by expressions which could + ;; erroneously match `symbolp'. + [[&or "from" "upfrom" "downfrom" "to" "upto" "downto" + "above" "below" "by" "in" "on" "=" "across" + "repeat" "while" "until" "always" "never" + "thereis" "collect" "append" "nconc" "sum" + "count" "maximize" "minimize" "if" "unless" + "return"] form] + ;; Simple default, which covers 99% of the cases. + symbolp form))) + (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list loop-args)))))) + `(cl-block nil (while t ,@loop-args)) + (let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil) + (cl--loop-body nil) (cl--loop-steps nil) + (cl--loop-result nil) (cl--loop-result-explicit nil) + (cl--loop-result-var nil) (cl--loop-finish-flag nil) + (cl--loop-accum-var nil) (cl--loop-accum-vars nil) + (cl--loop-initially nil) (cl--loop-finally nil) + (cl--loop-map-form nil) (cl--loop-first-flag nil) + (cl--loop-destr-temps nil) (cl--loop-symbol-macs nil)) + (setq cl--loop-args (append cl--loop-args '(cl-end-loop))) + (while (not (eq (car cl--loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) + (if cl--loop-finish-flag + (push `((,cl--loop-finish-flag t)) cl--loop-bindings)) + (if cl--loop-first-flag + (progn (push `((,cl--loop-first-flag t)) cl--loop-bindings) + (push `(setq ,cl--loop-first-flag nil) cl--loop-steps))) + (let* ((epilogue (nconc (nreverse cl--loop-finally) + (list (or cl--loop-result-explicit cl--loop-result)))) + (ands (cl--loop-build-ands (nreverse cl--loop-body))) + (while-body (nconc (cadr ands) (nreverse cl--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 `(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) - `((if ,loop-finish-flag - (progn ,@epilogue) ,loop-result-var))) + (nreverse cl--loop-initially) + (list (if cl--loop-map-form + `(cl-block --cl-finish-- + ,(cl-subst + (if (eq (car ands) t) while-body + (cons `(or ,(car ands) + (cl-return-from --cl-finish-- + nil)) + while-body)) + '--cl-map cl--loop-map-form)) + `(while ,(car ands) ,@while-body))) + (if cl--loop-finish-flag + (if (equal epilogue '(nil)) (list cl--loop-result-var) + `((if ,cl--loop-finish-flag + (progn ,@epilogue) ,cl--loop-result-var))) epilogue)))) - (if loop-result-var (push (list loop-result-var) loop-bindings)) - (while loop-bindings - (if (cdar loop-bindings) - (setq body (list (cl-loop-let (pop loop-bindings) body t))) + (if cl--loop-result-var (push (list cl--loop-result-var) cl--loop-bindings)) + (while cl--loop-bindings + (if (cdar cl--loop-bindings) + (setq body (list (cl--loop-let (pop cl--loop-bindings) body t))) (let ((lets nil)) - (while (and loop-bindings - (not (cdar loop-bindings))) - (push (car (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 (pop args)) + (while (and cl--loop-bindings + (not (cdar cl--loop-bindings))) + (push (car (pop cl--loop-bindings)) lets)) + (setq body (list (cl--loop-let lets body nil)))))) + (if cl--loop-symbol-macs + (setq body (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) + `(cl-block ,cl--loop-name ,@body))))) + +;; Below is a complete spec for cl-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 valid cl-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 cl-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)) + + + +(defun cl-parse-loop-clause () ; uses loop-* + (let ((word (pop cl--loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) (key-types '(key-code key-codes key-seq key-seqs key-binding key-bindings))) (cond - ((null args) - (error "Malformed `loop' macro")) + ((null cl--loop-args) + (error "Malformed `cl-loop' macro")) ((eq word 'named) - (setq loop-name (pop args))) + (setq cl--loop-name (pop cl--loop-args))) ((eq word 'initially) - (if (memq (car args) '(do doing)) (pop args)) - (or (consp (car args)) (error "Syntax error on `initially' clause")) - (while (consp (car args)) - (push (pop args) loop-initially))) + (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) + (or (consp (car cl--loop-args)) (error "Syntax error on `initially' clause")) + (while (consp (car cl--loop-args)) + (push (pop cl--loop-args) cl--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)) (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 (pop args)) '(quote nil))) - (while (consp (car args)) - (push (pop args) loop-finally))))) + (if (eq (car cl--loop-args) 'return) + (setq cl--loop-result-explicit (or (cl-pop2 cl--loop-args) '(quote nil))) + (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) + (or (consp (car cl--loop-args)) (error "Syntax error on `finally' clause")) + (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) + (setq cl--loop-result-explicit (or (nth 1 (pop cl--loop-args)) '(quote nil))) + (while (consp (car cl--loop-args)) + (push (pop cl--loop-args) cl--loop-finally))))) ((memq word '(for as)) (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) (ands nil)) (while - ;; Use `gensym' rather than `make-symbol'. It's important that + ;; Use `cl-gensym' rather than `make-symbol'. It's important that ;; (not (eq (symbol-name var1) (symbol-name var2))) because - ;; these vars get added to the cl-macro-environment. - (let ((var (or (pop args) (gensym "--cl-var--")))) - (setq word (pop args)) - (if (eq word 'being) (setq word (pop args))) - (if (memq word '(the each)) (setq word (pop args))) + ;; these vars get added to the macro-environment. + (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--")))) + (setq word (pop cl--loop-args)) + (if (eq word 'being) (setq word (pop cl--loop-args))) + (if (memq word '(the each)) (setq word (pop cl--loop-args))) (if (memq word '(buffer buffers)) - (setq word 'in args (cons '(buffer-list) args))) + (setq word 'in cl--loop-args (cons '(buffer-list) cl--loop-args))) (cond ((memq word '(from downfrom upfrom to downto upto above below by)) - (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) + (push word cl--loop-args) + (if (memq (car cl--loop-args) '(downto above)) + (error "Must specify `from' value for downward cl-loop")) + (let* ((down (or (eq (car cl--loop-args) 'downfrom) + (memq (cl-caddr cl--loop-args) '(downto above)))) + (excl (or (memq (car cl--loop-args) '(above below)) + (memq (cl-caddr cl--loop-args) '(above below)))) + (start (and (memq (car cl--loop-args) '(from upfrom downfrom)) + (cl-pop2 cl--loop-args))) + (end (and (memq (car cl--loop-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)) + (cl-pop2 cl--loop-args))) + (step (and (eq (car cl--loop-args) 'by) (cl-pop2 cl--loop-args))) + (end-var (and (not (macroexp-const-p end)) (make-symbol "--cl-var--"))) - (step-var (and (not (cl-const-expr-p step)) + (step-var (and (not (macroexp-const-p step)) (make-symbol "--cl-var--")))) (and step (numberp step) (<= step 0) (error "Loop `by' value is not positive: %s" step)) @@ -778,7 +1065,7 @@ Valid clauses are: (if end (push (list (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) loop-body)) + var (or end-var end)) cl--loop-body)) (push (list var (list (if down '- '+) var (or step-var step 1))) loop-for-steps))) @@ -787,44 +1074,44 @@ Valid clauses are: (let* ((on (eq word 'on)) (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) - (push (list temp (pop args)) loop-for-bindings) - (push (list 'consp temp) loop-body) + (push (list temp (pop cl--loop-args)) loop-for-bindings) + (push `(consp ,temp) cl--loop-body) (if (eq word 'in-ref) - (push (list var (list 'car temp)) loop-symbol-macs) + (push (list var `(car ,temp)) cl--loop-symbol-macs) (or (eq temp var) (progn (push (list var nil) loop-for-bindings) - (push (list var (if on temp (list 'car temp))) + (push (list var (if on temp `(car ,temp))) loop-for-sets)))) (push (list temp - (if (eq (car args) 'by) - (let ((step (cl-pop2 args))) + (if (eq (car cl--loop-args) 'by) + (let ((step (cl-pop2 cl--loop-args))) (if (and (memq (car-safe step) '(quote function - function*)) + cl-function)) (symbolp (nth 1 step))) (list (nth 1 step) temp) - (list 'funcall step temp))) - (list 'cdr temp))) + `(funcall ,step ,temp))) + `(cdr ,temp))) loop-for-steps))) ((eq word '=) - (let* ((start (pop args)) - (then (if (eq (car args) 'then) (cl-pop2 args) start))) + (let* ((start (pop cl--loop-args)) + (then (if (eq (car cl--loop-args) 'then) (cl-pop2 cl--loop-args) start))) (push (list var nil) loop-for-bindings) - (if (or ands (eq (car args) 'and)) + (if (or ands (eq (car cl--loop-args) 'and)) (progn (push `(,var - (if ,(or loop-first-flag - (setq loop-first-flag + (if ,(or cl--loop-first-flag + (setq cl--loop-first-flag (make-symbol "--cl-var--"))) ,start ,var)) loop-for-sets) (push (list var then) loop-for-steps)) (push (list var (if (eq start then) start - `(if ,(or loop-first-flag - (setq loop-first-flag + `(if ,(or cl--loop-first-flag + (setq cl--loop-first-flag (make-symbol "--cl-var--"))) ,start ,then))) loop-for-sets)))) @@ -832,80 +1119,79 @@ Valid clauses are: ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) (temp-idx (make-symbol "--cl-idx--"))) - (push (list temp-vec (pop args)) loop-for-bindings) + (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) - (push (list '< (list 'setq temp-idx (list '1+ temp-idx)) - (list 'length temp-vec)) loop-body) + (push `(< (setq ,temp-idx (1+ ,temp-idx)) + (length ,temp-vec)) cl--loop-body) (if (eq word 'across-ref) - (push (list var (list 'aref temp-vec temp-idx)) - loop-symbol-macs) + (push (list var `(aref ,temp-vec ,temp-idx)) + cl--loop-symbol-macs) (push (list var nil) loop-for-bindings) - (push (list var (list 'aref temp-vec temp-idx)) + (push (list var `(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))) + (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref)) + (and (not (memq (car cl--loop-args) '(in of))) (error "Expected `of'")))) - (seq (cl-pop2 args)) + (seq (cl-pop2 cl--loop-args)) (temp-seq (make-symbol "--cl-seq--")) - (temp-idx (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (eq (caadr args) 'index)) - (cadr (cl-pop2 args)) + (temp-idx (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (eq (cl-caadr cl--loop-args) 'index)) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-idx--")))) (push (list temp-seq seq) loop-for-bindings) (push (list temp-idx 0) loop-for-bindings) (if ref (let ((temp-len (make-symbol "--cl-len--"))) - (push (list temp-len (list 'length temp-seq)) + (push (list temp-len `(length ,temp-seq)) loop-for-bindings) - (push (list var (list 'elt temp-seq temp-idx)) - loop-symbol-macs) - (push (list '< temp-idx temp-len) loop-body)) + (push (list var `(elt ,temp-seq ,temp-idx)) + cl--loop-symbol-macs) + (push `(< ,temp-idx ,temp-len) cl--loop-body)) (push (list var nil) loop-for-bindings) - (push (list 'and temp-seq - (list 'or (list 'consp temp-seq) - (list '< temp-idx - (list 'length temp-seq)))) - loop-body) - (push (list var (list 'if (list 'consp temp-seq) - (list 'pop temp-seq) - (list 'aref temp-seq temp-idx))) + (push `(and ,temp-seq + (or (consp ,temp-seq) + (< ,temp-idx (length ,temp-seq)))) + cl--loop-body) + (push (list var `(if (consp ,temp-seq) + (pop ,temp-seq) + (aref ,temp-seq ,temp-idx))) loop-for-sets)) - (push (list temp-idx (list '1+ temp-idx)) + (push (list temp-idx `(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)) + (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) + (let* ((table (cl-pop2 cl--loop-args)) + (other (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (cl-caadr cl--loop-args) hash-types) + (not (eq (cl-caadr cl--loop-args) word))) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(hash-value hash-values)) (setq var (prog1 other (setq other var)))) - (setq loop-map-form + (setq cl--loop-map-form `(maphash (lambda (,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 + (let ((ob (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args)))) + (setq cl--loop-map-form `(mapatoms (lambda (,var) . --cl-map) ,ob)))) ((memq word '(overlay overlays extent extents)) (let ((buf nil) (from nil) (to nil)) - (while (memq (car 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 - `(cl-map-extents + (while (memq (car cl--loop-args) '(in of from to)) + (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) + (t (setq buf (cl-pop2 cl--loop-args))))) + (setq cl--loop-map-form + `(cl--map-overlays (lambda (,var ,(make-symbol "--cl-var--")) (progn . --cl-map) nil) ,buf ,from ,to)))) @@ -914,237 +1200,248 @@ Valid clauses are: (let ((buf nil) (prop nil) (from nil) (to nil) (var1 (make-symbol "--cl-var1--")) (var2 (make-symbol "--cl-var2--"))) - (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))))) + (while (memq (car cl--loop-args) '(in of property from to)) + (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'property) + (setq prop (cl-pop2 cl--loop-args))) + (t (setq buf (cl-pop2 cl--loop-args))))) (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) (setq var1 (car var) var2 (cdr var)) - (push (list var (list 'cons var1 var2)) loop-for-sets)) - (setq loop-map-form - `(cl-map-intervals + (push (list var `(cons ,var1 ,var2)) loop-for-sets)) + (setq cl--loop-map-form + `(cl--map-intervals (lambda (,var1 ,var2) . --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)) + (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) + (let ((cl-map (cl-pop2 cl--loop-args)) + (other (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (cl-caadr cl--loop-args) key-types) + (not (eq (cl-caadr cl--loop-args) word))) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(key-binding key-bindings)) (setq var (prog1 other (setq other var)))) - (setq loop-map-form + (setq cl--loop-map-form `(,(if (memq word '(key-seq key-seqs)) - 'cl-map-keymap-recursively 'map-keymap) - (lambda (,var ,other) . --cl-map) ,map)))) + 'cl--map-keymap-recursively 'map-keymap) + (lambda (,var ,other) . --cl-map) ,cl-map)))) ((memq word '(frame frames screen screens)) (let ((temp (make-symbol "--cl-var--"))) (push (list var '(selected-frame)) loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push (list 'prog1 (list 'not (list 'eq var temp)) - (list 'or temp (list 'setq temp var))) - loop-body) - (push (list var (list 'next-frame var)) + (push `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var))) + cl--loop-body) + (push (list var `(next-frame ,var)) loop-for-steps))) ((memq word '(window windows)) - (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) - (temp (make-symbol "--cl-var--"))) + (let ((scr (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args))) + (temp (make-symbol "--cl-var--")) + (minip (make-symbol "--cl-minip--"))) (push (list var (if scr - (list 'frame-selected-window scr) + `(frame-selected-window ,scr) '(selected-window))) loop-for-bindings) + ;; If we started in the minibuffer, we need to + ;; ensure that next-window will bring us back there + ;; at some point. (Bug#7492). + ;; (Consider using walk-windows instead of cl-loop if + ;; you care about such things.) + (push (list minip `(minibufferp (window-buffer ,var))) + loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push (list 'prog1 (list 'not (list 'eq var temp)) - (list 'or temp (list 'setq temp var))) - loop-body) - (push (list var (list 'next-window var)) loop-for-steps))) + (push `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var))) + cl--loop-body) + (push (list var `(next-window ,var ,minip)) + loop-for-steps))) (t + ;; This is an advertised interface: (info "(cl)Other Clauses"). (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)) + (eq (car cl--loop-args) 'and)) (setq ands t) - (pop args)) + (pop cl--loop-args)) (if (and ands loop-for-bindings) - (push (nreverse loop-for-bindings) loop-bindings) - (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) - loop-bindings))) + (push (nreverse loop-for-bindings) cl--loop-bindings) + (setq cl--loop-bindings (nconc (mapcar 'list loop-for-bindings) + cl--loop-bindings))) (if loop-for-sets - (push (list 'progn - (cl-loop-let (nreverse loop-for-sets) 'setq ands) - t) loop-body)) + (push `(progn + ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) + t) cl--loop-body)) (if loop-for-steps - (push (cons (if ands 'psetq 'setq) + (push (cons (if ands 'cl-psetq 'setq) (apply 'append (nreverse loop-for-steps))) - loop-steps)))) + cl--loop-steps)))) ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) - (push (list (list temp (pop args))) loop-bindings) - (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) + (push (list (list temp (pop cl--loop-args))) cl--loop-bindings) + (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body))) ((memq word '(collect collecting)) - (let ((what (pop args)) - (var (cl-loop-handle-accum nil 'nreverse))) - (if (eq var loop-accum-var) - (push (list 'progn (list 'push what var) t) loop-body) - (push (list 'progn - (list 'setq var (list 'nconc var (list 'list what))) - t) loop-body)))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum nil 'nreverse))) + (if (eq var cl--loop-accum-var) + (push `(progn (push ,what ,var) t) cl--loop-body) + (push `(progn + (setq ,var (nconc ,var (list ,what))) + t) cl--loop-body)))) ((memq word '(nconc nconcing append appending)) - (let ((what (pop args)) - (var (cl-loop-handle-accum nil 'nreverse))) - (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))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum nil 'nreverse))) + (push `(progn + (setq ,var + ,(if (eq var cl--loop-accum-var) + `(nconc + (,(if (memq word '(nconc nconcing)) + #'nreverse #'reverse) + ,what) + ,var) + `(,(if (memq word '(nconc nconcing)) + #'nconc #'append) + ,var ,what))) t) cl--loop-body))) ((memq word '(concat concating)) - (let ((what (pop args)) - (var (cl-loop-handle-accum ""))) - (push (list 'progn (list 'callf 'concat var what) t) loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum ""))) + (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body))) ((memq word '(vconcat vconcating)) - (let ((what (pop args)) - (var (cl-loop-handle-accum []))) - (push (list 'progn (list 'callf 'vconcat var what) t) loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum []))) + (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body))) ((memq word '(sum summing)) - (let ((what (pop args)) - (var (cl-loop-handle-accum 0))) - (push (list 'progn (list 'incf var what) t) loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum 0))) + (push `(progn (cl-incf ,var ,what) t) cl--loop-body))) ((memq word '(count counting)) - (let ((what (pop args)) - (var (cl-loop-handle-accum 0))) - (push (list 'progn (list 'if what (list 'incf var)) t) loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum 0))) + (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (pop args)) - (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--"))) - (var (cl-loop-handle-accum nil)) + (let* ((what (pop cl--loop-args)) + (temp (if (cl--simple-expr-p what) what (make-symbol "--cl-var--"))) + (var (cl--loop-handle-accum nil)) (func (intern (substring (symbol-name word) 0 3))) - (set (list 'setq var (list 'if var (list func var temp) temp)))) - (push (list 'progn (if (eq temp what) set - (list 'let (list (list temp what)) set)) - t) loop-body))) + (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) + (push `(progn ,(if (eq temp what) set + `(let ((,temp ,what)) ,set)) + t) cl--loop-body))) ((eq word 'with) (let ((bindings nil)) - (while (progn (push (list (pop args) - (and (eq (car args) '=) (cl-pop2 args))) + (while (progn (push (list (pop cl--loop-args) + (and (eq (car cl--loop-args) '=) (cl-pop2 cl--loop-args))) bindings) - (eq (car args) 'and)) - (pop args)) - (push (nreverse bindings) loop-bindings))) + (eq (car cl--loop-args) 'and)) + (pop cl--loop-args)) + (push (nreverse bindings) cl--loop-bindings))) ((eq word 'while) - (push (pop args) loop-body)) + (push (pop cl--loop-args) cl--loop-body)) ((eq word 'until) - (push (list 'not (pop args)) loop-body)) + (push `(not ,(pop cl--loop-args)) cl--loop-body)) ((eq word 'always) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push (list 'setq loop-finish-flag (pop args)) loop-body) - (setq loop-result t)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body) + (setq cl--loop-result t)) ((eq word 'never) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push (list 'setq loop-finish-flag (list 'not (pop args))) - loop-body) - (setq loop-result t)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args))) + cl--loop-body) + (setq cl--loop-result t)) ((eq word 'thereis) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) - (push (list 'setq loop-finish-flag - (list 'not (list 'setq loop-result-var (pop args)))) - loop-body)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-finish-flag + (not (setq ,cl--loop-result-var ,(pop cl--loop-args)))) + cl--loop-body)) ((memq word '(if when unless)) - (let* ((cond (pop args)) - (then (let ((loop-body nil)) + (let* ((cond (pop cl--loop-args)) + (then (let ((cl--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 (pop args) (cl-parse-loop-clause))) - (cl-loop-build-ands (nreverse loop-body)))) + (cl--loop-build-ands (nreverse cl--loop-body)))) + (else (let ((cl--loop-body nil)) + (if (eq (car cl--loop-args) 'else) + (progn (pop cl--loop-args) (cl-parse-loop-clause))) + (cl--loop-build-ands (nreverse cl--loop-body)))) (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car args) 'end) (pop args)) + (if (eq (car cl--loop-args) 'end) (pop cl--loop-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) + (if (cl--expr-contains form 'it) (let ((temp (make-symbol "--cl-var--"))) - (push (list temp) loop-bindings) - (setq form (list* 'if (list 'setq temp cond) - (subst temp 'it form)))) - (setq form (list* 'if cond form))) - (push (if simple (list 'progn form t) form) loop-body)))) + (push (list temp) cl--loop-bindings) + (setq form `(if (setq ,temp ,cond) + ,@(cl-subst temp 'it form)))) + (setq form `(if ,cond ,@form))) + (push (if simple `(progn ,form t) form) cl--loop-body)))) ((memq word '(do doing)) (let ((body nil)) - (or (consp (car args)) (error "Syntax error on `do' clause")) - (while (consp (car args)) (push (pop args) body)) - (push (cons 'progn (nreverse (cons t body))) loop-body))) + (or (consp (car cl--loop-args)) (error "Syntax error on `do' clause")) + (while (consp (car cl--loop-args)) (push (pop cl--loop-args) body)) + (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) ((eq word 'return) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--"))) - (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) - (push (list 'setq loop-result-var (pop args) - loop-finish-flag nil) loop-body)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-var--"))) + (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-result-var ,(pop cl--loop-args) + ,cl--loop-finish-flag nil) cl--loop-body)) (t + ;; This is an advertised interface: (info "(cl)Other Clauses"). (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) - (or handler (error "Expected a loop keyword, found %s" word)) + (or handler (error "Expected a cl-loop keyword, found %s" word)) (funcall handler)))) - (if (eq (car args) 'and) - (progn (pop args) (cl-parse-loop-clause))))) + (if (eq (car cl--loop-args) 'and) + (progn (pop cl--loop-args) (cl-parse-loop-clause))))) -(defun cl-loop-let (specs body par) ; uses loop-* +(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)))) + (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p)))) (setq p (cdr p))) (and par p (progn (setq par nil p specs) (while p - (or (cl-const-expr-p (cadar p)) + (or (macroexp-const-p (cl-cadar p)) (let ((temp (make-symbol "--cl-var--"))) - (push (list temp (cadar p)) temps) + (push (list temp (cl-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 (pop specs))) - (temp (cdr (or (assq spec loop-destr-temps) + (temp (cdr (or (assq spec cl--loop-destr-temps) (car (push (cons spec (or (last spec 0) (make-symbol "--cl-var--"))) - loop-destr-temps)))))) + cl--loop-destr-temps)))))) (push (list temp expr) new) (while (consp spec) (push (list (pop spec) @@ -1153,29 +1450,36 @@ Valid clauses are: (setq specs (nconc (nreverse nspecs) specs))) (push (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 (push (list (list var def)) loop-bindings) - (push var loop-accum-vars))) + (let ((set (cons (if par 'cl-psetq 'setq) (apply 'nconc (nreverse new))))) + (if temps `(let* ,(nreverse temps) ,set) set)) + `(,(if par 'let 'let*) + ,(nconc (nreverse temps) (nreverse new)) ,@body)))) + +(defun cl--loop-handle-accum (def &optional func) ; uses loop-* + (if (eq (car cl--loop-args) 'into) + (let ((var (cl-pop2 cl--loop-args))) + (or (memq var cl--loop-accum-vars) + (progn (push (list (list var def)) cl--loop-bindings) + (push var cl--loop-accum-vars))) var) - (or loop-accum-var + (or cl--loop-accum-var (progn - (push (list (list (setq loop-accum-var (make-symbol "--cl-var--")) 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) + (push (list (list (setq cl--loop-accum-var (make-symbol "--cl-var--")) def)) + cl--loop-bindings) + (setq cl--loop-result (if func (list func cl--loop-accum-var) + cl--loop-accum-var)) + cl--loop-accum-var)))) + +(defun cl--loop-build-ands (clauses) + "Return various representations of (and . CLAUSES). +CLAUSES is a list of Elisp expressions, where clauses of the form +\(progn E1 E2 E3 .. t) are the focus of particular optimizations. +The return value has shape (COND BODY COMBO) +such that COMBO is equivalent to (and . CLAUSES)." (let ((ands nil) (body nil)) + ;; Look through `clauses', trying to optimize (progn ,@A t) (progn ,@B) ,@C + ;; into (progn ,@A ,@B) ,@C. (while clauses (if (and (eq (car-safe (car clauses)) 'progn) (eq (car (last (car clauses))) t)) @@ -1183,9 +1487,10 @@ Valid clauses are: (setq clauses (cons (nconc (butlast (car clauses)) (if (eq (car-safe (cadr clauses)) 'progn) - (cdadr clauses) + (cl-cdadr clauses) (list (cadr clauses)))) (cddr clauses))) + ;; A final (progn ,@A t) is moved outside of the `and'. (setq body (cdr (butlast (pop clauses))))) (push (pop clauses) ands))) (setq ands (or (nreverse ands) (list t))) @@ -1200,329 +1505,401 @@ Valid clauses are: ;;; Other iteration control structures. ;;;###autoload -(defmacro do (steps endtest &rest body) +(defmacro cl-do (steps endtest &rest body) "The Common Lisp `do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" + (declare (indent 2) + (debug + ((&rest &or symbolp (symbolp &optional form form)) + (form body) + cl-declarations body))) (cl-expand-do-loop steps endtest body nil)) ;;;###autoload -(defmacro do* (steps endtest &rest body) +(defmacro cl-do* (steps endtest &rest body) "The Common Lisp `do*' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" + (declare (indent 2) (debug cl-do)) (cl-expand-do-loop steps endtest body t)) (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))))) + `(cl-block nil + (,(if star 'let* 'let) + ,(mapcar (lambda (c) (if (consp c) (list (car c) (nth 1 c)) c)) + steps) + (while (not ,(car endtest)) + ,@body + ,@(let ((sets (mapcar (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 'cl-psetq) + (apply 'append sets)))))) + ,@(or (cdr endtest) '(nil))))) ;;;###autoload -(defmacro dolist (spec &rest body) +(defmacro cl-dolist (spec &rest 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. +An implicit nil block is established around the loop. \(fn (VAR LIST [RESULT]) BODY...)" - (let ((temp (make-symbol "--cl-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)))))) + (declare (debug ((symbolp form &optional form) cl-declarations body)) + (indent 1)) + `(cl-block nil + (,(if (eq 'cl-dolist (symbol-function 'dolist)) 'cl--dolist 'dolist) + ,spec ,@body))) ;;;###autoload -(defmacro dotimes (spec &rest body) +(defmacro cl-dotimes (spec &rest 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. \(fn (VAR COUNT [RESULT]) BODY...)" - (let ((temp (make-symbol "--cl-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)))))) + (declare (debug cl-dolist) (indent 1)) + `(cl-block nil + (,(if (eq 'cl-dotimes (symbol-function 'dotimes)) 'cl--dotimes 'dotimes) + ,spec ,@body))) ;;;###autoload -(defmacro do-symbols (spec &rest body) +(defmacro cl-do-symbols (spec &rest body) "Loop over all symbols. Evaluate BODY with VAR bound to each interned symbol, or to each symbol from OBARRAY. \(fn (VAR [OBARRAY [RESULT]]) BODY...)" + (declare (indent 1) + (debug ((symbolp &optional form form) cl-declarations body))) ;; 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)))) + `(cl-block nil + (let (,(car spec)) + (mapatoms #'(lambda (,(car spec)) ,@body) + ,@(and (cadr spec) (list (cadr spec)))) + ,(cl-caddr spec)))) ;;;###autoload -(defmacro do-all-symbols (spec &rest body) - (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) +(defmacro cl-do-all-symbols (spec &rest body) + "Like `cl-do-symbols', but use the default obarray. + +\(fn (VAR [RESULT]) BODY...)" + (declare (indent 1) (debug ((symbolp &optional form) cl-declarations body))) + `(cl-do-symbols (,(car spec) nil ,(cadr spec)) ,@body)) ;;; Assignments. ;;;###autoload -(defmacro psetq (&rest args) +(defmacro cl-psetq (&rest args) "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. \(fn SYM VAL SYM VAL ...)" - (cons 'psetf args)) + (declare (debug setq)) + (cons 'cl-psetf args)) ;;; Binding control structures. ;;;###autoload -(defmacro progv (symbols values &rest body) +(defmacro cl-progv (symbols values &rest 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 +second list (or to nil if VALUES is shorter than SYMBOLS); then the BODY forms are executed and their result is returned. This is much like a `let' form, except that the list of symbols can be computed at run-time." - (list 'let '((cl-progv-save nil)) - (list 'unwind-protect - (list* 'progn (list 'cl-progv-before symbols values) body) - '(cl-progv-after)))) + (declare (indent 2) (debug (form form body))) + (let ((bodyfun (make-symbol "cl--progv-body")) + (binds (make-symbol "binds")) + (syms (make-symbol "syms")) + (vals (make-symbol "vals"))) + `(progn + (defvar ,bodyfun) + (let* ((,syms ,symbols) + (,vals ,values) + (,bodyfun (lambda () ,@body)) + (,binds ())) + (while ,syms + (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) + (eval (list 'let ,binds '(funcall ,bodyfun))))))) + +(defvar cl--labels-convert-cache nil) + +(defun cl--labels-convert (f) + "Special macro-expander to rename (function F) references in `cl-labels'." + (cond + ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked + ;; *after* handling `function', but we want to stop macroexpansion from + ;; being applied infinitely, so we use a cache to return the exact `form' + ;; being expanded even though we don't receive it. + ((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache)) + (t + (let ((found (assq f macroexpand-all-environment))) + (if (and found (ignore-errors + (eq (cadr (cl-caddr found)) 'cl-labels-args))) + (cadr (cl-caddr (cl-cadddr found))) + (let ((res `(function ,f))) + (setq cl--labels-convert-cache (cons f res)) + res)))))) -;;; This should really have some way to shadow 'byte-compile properties, etc. ;;;###autoload -(defmacro flet (bindings &rest body) - "Make temporary function definitions. -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). +(defmacro cl-flet (bindings &rest body) + "Make local function definitions. +Like `cl-labels' but the definitions are not recursive. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (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)))))) - (when (cl-compiling-file) - ;; Bug#411. It would be nice to fix this. - (and (get (car x) 'byte-compile) - (error "Byte-compiling a redefinition of `%s' \ -will not work - use `labels' instead" (symbol-name (car x)))) - ;; FIXME This affects the rest of the file, when it - ;; should be restricted to the flet body. - (and (boundp 'byte-compile-function-environment) - (push (cons (car x) (eval func)) - byte-compile-function-environment))) - (list (list 'symbol-function (list 'quote (car x))) func)))) - bindings) - body)) + (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) + (let ((binds ()) (newenv macroexpand-all-environment)) + (dolist (binding bindings) + (let ((var (make-symbol (format "--cl-%s--" (car binding))))) + (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (push (cons (car binding) + `(lambda (&rest cl-labels-args) + (cl-list* 'funcall ',var + cl-labels-args))) + newenv))) + `(let ,(nreverse binds) + ,@(macroexp-unprogn + (macroexpand-all + `(progn ,@body) + ;; Don't override lexical-let's macro-expander. + (if (assq 'function newenv) newenv + (cons (cons 'function #'cl--labels-convert) newenv))))))) ;;;###autoload -(defmacro labels (bindings &rest body) +(defmacro cl-flet* (bindings &rest body) + "Make local function definitions. +Like `cl-flet' but the definitions can refer to previous ones. + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (declare (indent 1) (debug cl-flet)) + (cond + ((null bindings) (macroexp-progn body)) + ((null (cdr bindings)) `(cl-flet ,bindings ,@body)) + (t `(cl-flet (,(pop bindings)) (cl-flet* ,bindings ,@body))))) + +;;;###autoload +(defmacro cl-labels (bindings &rest body) "Make temporary function bindings. -This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully compliant with the Common Lisp standard. +The bindings can be recursive and the scoping is lexical, but capturing them +in closures will only work if `lexical-binding' is in use. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) - (while bindings - ;; Use `gensym' rather than `make-symbol'. It's important that - ;; (not (eq (symbol-name var1) (symbol-name var2))) because these - ;; vars get added to the cl-macro-environment. - (let ((var (gensym "--cl-var--"))) - (push var vars) - (push (list 'function* (cons 'lambda (cdar bindings))) sets) - (push var sets) - (push (list (car (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))) + (declare (indent 1) (debug cl-flet)) + (let ((binds ()) (newenv macroexpand-all-environment)) + (dolist (binding bindings) + (let ((var (make-symbol (format "--cl-%s--" (car binding))))) + (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (push (cons (car binding) + `(lambda (&rest cl-labels-args) + (cl-list* 'funcall ',var + cl-labels-args))) + newenv))) + (macroexpand-all `(letrec ,(nreverse binds) ,@body) + ;; Don't override lexical-let's macro-expander. + (if (assq 'function newenv) newenv + (cons (cons 'function #'cl--labels-convert) newenv))))) ;; The following ought to have a better definition for use with newer ;; byte compilers. ;;;###autoload -(defmacro macrolet (bindings &rest body) +(defmacro cl-macrolet (bindings &rest body) "Make temporary macro definitions. -This is like `flet', but for macros instead of functions. +This is like `cl-flet', but for macros instead of functions. \(fn ((NAME ARGLIST BODY...) ...) FORM...)" + (declare (indent 1) + (debug + ((&rest (&define name (&rest arg) cl-declarations-or-string + def-body)) + cl-declarations body))) (if (cdr bindings) - (list 'macrolet - (list (car bindings)) (list* 'macrolet (cdr bindings) body)) + `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) (if (null bindings) (cons 'progn body) (let* ((name (caar bindings)) - (res (cl-transform-lambda (cdar bindings) name))) + (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)))))) + (macroexpand-all (cons 'progn body) + (cons (cons name `(lambda ,@(cdr res))) + macroexpand-all-environment)))))) + +(defconst cl--old-macroexpand + (if (and (boundp 'cl--old-macroexpand) + (eq (symbol-function 'macroexpand) + #'cl--sm-macroexpand)) + cl--old-macroexpand + (symbol-function 'macroexpand))) + +(defun cl--sm-macroexpand (exp &optional env) + "Special macro expander used inside `cl-symbol-macrolet'. +This function replaces `macroexpand' during macro expansion +of `cl-symbol-macrolet', and does the same thing as `macroexpand' +except that it additionally expands symbol macros." + (let ((macroexpand-all-environment env)) + (while + (progn + (setq exp (funcall cl--old-macroexpand exp env)) + (pcase exp + ((pred symbolp) + ;; Perform symbol-macro expansion. + (when (cdr (assq (symbol-name exp) env)) + (setq exp (cadr (assq (symbol-name exp) env))))) + (`(setq . ,_) + ;; Convert setq to setf if required by symbol-macro expansion. + (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env)) + (cdr exp))) + (p args)) + (while (and p (symbolp (car p))) (setq p (cddr p))) + (if p (setq exp (cons 'setf args)) + (setq exp (cons 'setq args)) + ;; Don't loop further. + nil))) + (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) + ;; CL's symbol-macrolet treats re-bindings as candidates for + ;; expansion (turning the let into a letf if needed), contrary to + ;; Common-Lisp where such re-bindings hide the symbol-macro. + (let ((letf nil) (found nil) (nbs ())) + (dolist (binding bindings) + (let* ((var (if (symbolp binding) binding (car binding))) + (sm (assq (symbol-name var) env))) + (push (if (not (cdr sm)) + binding + (let ((nexp (cadr sm))) + (setq found t) + (unless (symbolp nexp) (setq letf t)) + (cons nexp (cdr-safe binding)))) + nbs))) + (when found + (setq exp `(,(if letf + (if (eq (car exp) 'let) 'cl-letf 'cl-letf*) + (car exp)) + ,(nreverse nbs) + ,@body))))) + ;; FIXME: The behavior of CL made sense in a dynamically scoped + ;; language, but for lexical scoping, Common-Lisp's behavior might + ;; make more sense (and indeed, CL behaves like Common-Lisp w.r.t + ;; lexical-let), so maybe we should adjust the behavior based on + ;; the use of lexical-binding. + ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) + ;; (let ((nbs ()) (found nil)) + ;; (dolist (binding bindings) + ;; (let* ((var (if (symbolp binding) binding (car binding))) + ;; (name (symbol-name var)) + ;; (val (and found (consp binding) (eq 'let* (car exp)) + ;; (list (macroexpand-all (cadr binding) + ;; env))))) + ;; (push (if (assq name env) + ;; ;; This binding should hide its symbol-macro, + ;; ;; but given the way macroexpand-all works, we + ;; ;; can't prevent application of `env' to the + ;; ;; sub-expressions, so we need to α-rename this + ;; ;; variable instead. + ;; (let ((nvar (make-symbol + ;; (copy-sequence name)))) + ;; (setq found t) + ;; (push (list name nvar) env) + ;; (cons nvar (or val (cdr-safe binding)))) + ;; (if val (cons var val) binding)) + ;; nbs))) + ;; (when found + ;; (setq exp `(,(car exp) + ;; ,(nreverse nbs) + ;; ,@(macroexp-unprogn + ;; (macroexpand-all (macroexp-progn body) + ;; env))))) + ;; nil)) + ))) + exp)) ;;;###autoload -(defmacro symbol-macrolet (bindings &rest body) +(defmacro cl-symbol-macrolet (bindings &rest body) "Make symbol macro definitions. Within the body FORMs, references to the variable NAME will be replaced by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" - (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) -;;;###autoload -(defmacro lexical-let (bindings &rest body) - "Like `let', but lexically scoped. -The main visible difference is that lambdas inside BODY will create -lexical closures as in Common Lisp. -\n(fn VARLIST BODY)" - (let* ((cl-closure-vars cl-closure-vars) - (vars (mapcar (function - (lambda (x) - (or (consp x) (setq x (list x))) - (push (make-symbol (format "--cl-%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)))) - -;;;###autoload -(defmacro lexical-let* (bindings &rest body) - "Like `let*', but lexically scoped. -The main visible difference is that lambdas inside BODY, and in -successive bindings within VARLIST, will create lexical closures -as in Common Lisp. This is similar to the behavior of `let*' in -Common Lisp. -\n(fn VARLIST BODY)" - (if (null bindings) (cons 'progn body) - (setq bindings (reverse bindings)) - (while bindings - (setq body (list (list* 'lexical-let (list (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))) - + (declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body))) + (cond + ((cdr bindings) + `(cl-symbol-macrolet (,(car bindings)) + (cl-symbol-macrolet ,(cdr bindings) ,@body))) + ((null bindings) (macroexp-progn body)) + (t + (let ((previous-macroexpand (symbol-function 'macroexpand))) + (unwind-protect + (progn + (fset 'macroexpand #'cl--sm-macroexpand) + ;; FIXME: For N bindings, this will traverse `body' N times! + (macroexpand-all (cons 'progn body) + (cons (list (symbol-name (caar bindings)) + (cl-cadar bindings)) + macroexpand-all-environment))) + (fset 'macroexpand previous-macroexpand)))))) ;;; Multiple values. ;;;###autoload -(defmacro multiple-value-bind (vars form &rest body) +(defmacro cl-multiple-value-bind (vars form &rest 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 +is analogous to the Common Lisp `cl-multiple-value-bind' macro, using lists to +simulate true multiple return values. For compatibility, (cl-values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM BODY)" + (declare (indent 2) (debug ((&rest symbolp) form body))) (let ((temp (make-symbol "--cl-var--")) (n -1)) - (list* 'let* (cons (list temp form) - (mapcar (function - (lambda (v) - (list v (list 'nth (setq n (1+ n)) temp)))) - vars)) - body))) + `(let* ((,temp ,form) + ,@(mapcar (lambda (v) + (list v `(nth ,(setq n (1+ n)) ,temp))) + vars)) + ,@body))) ;;;###autoload -(defmacro multiple-value-setq (vars form) +(defmacro cl-multiple-value-setq (vars 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). +`cl-multiple-value-setq' macro, using lists to simulate true multiple return +values. For compatibility, (cl-values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM)" - (cond ((null vars) (list 'progn form nil)) - ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) + (declare (indent 1) (debug ((&rest symbolp) form))) + (cond ((null vars) `(progn ,form nil)) + ((null (cdr vars)) `(setq ,(car vars) (car ,form))) (t (let* ((temp (make-symbol "--cl-var--")) (n 0)) - (list 'let (list (list temp form)) - (list 'prog1 (list 'setq (pop vars) (list 'car temp)) - (cons 'setq (apply 'nconc - (mapcar (function - (lambda (v) - (list v (list - 'nth - (setq n (1+ n)) - temp)))) - vars))))))))) + `(let ((,temp ,form)) + (prog1 (setq ,(pop vars) (car ,temp)) + (setq ,@(apply #'nconc + (mapcar (lambda (v) + (list v `(nth ,(setq n (1+ n)) + ,temp))) + vars))))))))) ;;; Declarations. ;;;###autoload -(defmacro locally (&rest body) (cons 'progn body)) +(defmacro cl-locally (&rest body) + "Equivalent to `progn'." + (declare (debug t)) + (cons 'progn body)) ;;;###autoload -(defmacro the (type form) form) +(defmacro cl-the (_type form) + "At present this ignores _TYPE and is simply equivalent to FORM." + (declare (indent 1) (debug (cl-type-spec form))) + form) (defvar cl-proclaim-history t) ; for future compilers (defvar cl-declare-stack t) ; for future compilers @@ -1561,7 +1938,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) (while (setq spec (cdr spec)) (if (consp (car spec)) - (if (eq (cadar spec) 0) + (if (eq (cl-cadar spec) 0) (byte-compile-disable-warning (caar spec)) (byte-compile-enable-warning (caar spec))))))) nil) @@ -1573,500 +1950,159 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). (setq cl-proclaims-deferred nil)) ;;;###autoload -(defmacro declare (&rest specs) - (if (cl-compiling-file) +(defmacro cl-declare (&rest specs) + "Declare SPECS about the current function while compiling. +For instance + + \(cl-declare (warn 0)) + +will turn off byte-compile warnings in the function. +See Info node `(cl)Declarations' for details." + (if (cl--compiling-file) (while specs (if (listp cl-declare-stack) (push (car specs) cl-declare-stack)) (cl-do-proclaim (pop specs) nil))) nil) - - -;;; Generalized variables. - -;;;###autoload -(defmacro define-setf-method (func args &rest body) - "Define a `setf' method. -This method shows how to handle `setf's to places of the form (NAME ARGS...). -The argument forms ARGS are bound according to ARGLIST, as if NAME were -going to be expanded as a macro, then the BODY forms are executed and must -return a list of five elements: a temporary-variables list, a value-forms -list, a store-variables list (of length one), a store-form, and an access- -form. See `defsetf' for a simpler way to define most setf-methods. - -\(fn NAME ARGLIST BODY...)" - (append '(eval-when (compile load eval)) - (if (stringp (car body)) - (list (list 'put (list 'quote func) '(quote setf-documentation) - (pop body)))) - (list (cl-transform-function-property - func 'setf-method (cons args body))))) -(defalias 'define-setf-expander 'define-setf-method) - -;;;###autoload -(defmacro defsetf (func arg1 &rest args) - "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)) - -\(fn NAME [FUNC | ARGLIST (STORE) BODY...])" - (if (and (listp arg1) (consp args)) - (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 `(,(car p2) - (make-symbol ,(format "--cl-%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))) - `(define-setf-method ,func ,arg1 - ,@(and docstr (list docstr)) - (let* - ,(nreverse - (cons `(,store-temp - (make-symbol ,(format "--cl-%s--" store-var))) - (if restarg - `((,rest-temps - (mapcar (lambda (_) (make-symbol "--cl-var--")) - ,restarg)) - ,@lets1) - lets1))) - (list ; 'values - (,(if restarg 'list* 'list) ,@tempsr) - (,(if restarg 'list* 'list) ,@largsr) - (list ,store-temp) - (let* - ,(nreverse - (cons (list store-var store-temp) - lets2)) - ,@args) - (,(if restarg 'list* 'list) - ,@(cons (list 'quote func) tempsr)))))) - `(defsetf ,func (&rest args) (store) - ,(let ((call `(cons ',arg1 - (append args (list store))))) - (if (car args) - `(list 'progn ,call store) - call))))) - -;;; Some standard place types from Common Lisp. -(defsetf aref aset) -(defsetf car setcar) -(defsetf cdr setcdr) -(defsetf caar (x) (val) (list 'setcar (list 'car x) val)) -(defsetf cadr (x) (val) (list 'setcar (list 'cdr x) val)) -(defsetf cdar (x) (val) (list 'setcdr (list 'car x) val)) -(defsetf cddr (x) (val) (list 'setcdr (list 'cdr x) val)) -(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 '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 (&optional buf) (flag) - (list 'with-current-buffer buf - (list 'set-buffer-modified-p flag))) -(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 frame-parameter set-frame-parameter 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 set-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 process-get process-put) -(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 (make-symbol "--cl-nthcdr-n--")) - (store-temp (make-symbol "--cl-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 (make-symbol "--cl-getf-tag--")) - (def-temp (make-symbol "--cl-getf-def--")) - (store-temp (make-symbol "--cl-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 (make-symbol "--cl-substring-from--")) - (to-temp (make-symbol "--cl-substring-to--")) - (store-temp (make-symbol "--cl-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. -;;;###autoload -(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 (make-symbol "--cl-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 (string-match-p "\\`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))) - (push (cons (pop temps) (pop values)) subs) - (push (list (pop temps) (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. -;;;###autoload -(defmacro setf (&rest args) - "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. -\(fn PLACE VAL PLACE VAL ...)" - (if (cdr (cdr args)) - (let ((sets nil)) - (while args (push (list 'setf (pop args) (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))))) +;; `setf' is now part of core Elisp, defined in gv.el. ;;;###autoload -(defmacro psetf (&rest args) +(defmacro cl-psetf (&rest args) "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. \(fn PLACE VAL PLACE VAL ...)" + (declare (debug setf)) (let ((p args) (simple t) (vars nil)) (while p - (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars)) + (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))) (push (pop p) vars) - (or p (error "Odd number of arguments to psetf")) + (or p (error "Odd number of arguments to cl-psetf")) (pop p)) (if simple - (list 'progn (cons 'setf args) nil) + `(progn (setq ,@args) nil) (setq args (reverse args)) - (let ((expr (list 'setf (cadr args) (car args)))) + (let ((expr `(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))))) + (setq expr `(setf ,(cadr args) (prog1 ,(car args) ,expr)))) + `(progn ,expr nil))))) ;;;###autoload -(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 (make-symbol "--cl-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))))))) - -;;;###autoload -(defmacro remf (place tag) +(defmacro cl-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)) (make-symbol "--cl-remf-tag--"))) - (val-temp (and (not (cl-simple-expr-p place)) - (make-symbol "--cl-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))))) + (declare (debug (place form))) + (gv-letplace (tval setter) place + (macroexp-let2 macroexp-copyable-p ttag tag + `(if (eq ,ttag (car ,tval)) + (progn ,(funcall setter `(cddr ,tval)) + t) + (cl--do-remf ,tval ,ttag))))) ;;;###autoload -(defmacro shiftf (place &rest args) +(defmacro cl-shiftf (place &rest args) "Shift left among PLACEs. -Example: (shiftf A B C) sets A to B, B to C, and returns the old A. +Example: (cl-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'. \(fn PLACE... VAL)" + (declare (debug (&rest place))) (cond ((null args) place) - ((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args)))) + ((symbolp place) `(prog1 ,place (setq ,place (cl-shiftf ,@args)))) (t - (let ((method (cl-setf-do-modify place 'unsafe))) - `(let* ,(car method) - (prog1 ,(nth 2 method) - ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args)))))))) + (gv-letplace (getter setter) place + `(prog1 ,getter + ,(funcall setter `(cl-shiftf ,@args))))))) ;;;###autoload -(defmacro rotatef (&rest args) +(defmacro cl-rotatef (&rest args) "Rotate left among PLACEs. -Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. +Example: (cl-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'. \(fn PLACE...)" + (declare (debug (&rest place))) (if (not (memq nil (mapcar 'symbolp args))) (and (cdr args) (let ((sets nil) (first (car args))) (while (cdr args) (setq sets (nconc sets (list (pop args) (car args))))) - (nconc (list 'psetf) sets (list (car args) first)))) + `(cl-psetf ,@sets ,(car args) ,first))) (let* ((places (reverse args)) (temp (make-symbol "--cl-rotatef--")) (form temp)) (while (cdr places) - (let ((method (cl-setf-do-modify (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))))) + (setq form + (gv-letplace (getter setter) (pop places) + `(prog1 ,getter ,(funcall setter form))))) + (gv-letplace (getter setter) (car places) + (macroexp-let* `((,temp ,getter)) + `(progn ,(funcall setter form) nil)))))) + +;; FIXME: `letf' is unsatisfactory because it does not really "restore" the +;; previous state. If the getter/setter loses information, that info is +;; not recovered. + +(defun cl--letf (bindings simplebinds binds body) + ;; It's not quite clear what the semantics of cl-letf should be. + ;; E.g. in (cl-letf ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear + ;; that the actual assignments ("bindings") should only happen after + ;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions of + ;; PLACE1 and PLACE2 should be evaluated. Should we have + ;; PLACE1; VAL1; PLACE2; VAL2; bind1; bind2 + ;; or + ;; VAL1; VAL2; PLACE1; PLACE2; bind1; bind2 + ;; or + ;; VAL1; VAL2; PLACE1; bind1; PLACE2; bind2 + ;; Common-Lisp's `psetf' does the first, so we'll do the same. + (if (null bindings) + (if (and (null binds) (null simplebinds)) (macroexp-progn body) + `(let* (,@(mapcar (lambda (x) + (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x)) + (list vold getter))) + binds) + ,@simplebinds) + (unwind-protect + ,(macroexp-progn + (append + (delq nil + (mapcar (lambda (x) + (pcase x + ;; If there's no vnew, do nothing. + (`(,_vold ,_getter ,setter ,vnew) + (funcall setter vnew)))) + binds)) + body)) + ,@(mapcar (lambda (x) + (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) + (funcall setter vold))) + binds)))) + (let ((binding (car bindings))) + (gv-letplace (getter setter) (car binding) + (macroexp-let2 nil vnew (cadr binding) + (if (symbolp (car binding)) + ;; Special-case for simple variables. + (cl--letf (cdr bindings) + (cons `(,getter ,(if (cdr binding) vnew getter)) + simplebinds) + binds body) + (cl--letf (cdr bindings) simplebinds + (cons `(,(make-symbol "old") ,getter ,setter + ,@(if (cdr binding) (list vnew))) + binds) + body))))))) ;;;###autoload -(defmacro letf (bindings &rest body) +(defmacro cl-letf (bindings &rest 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 @@ -2077,119 +2113,53 @@ As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" + (declare (indent 1) (debug ((&rest (gate gv-place &optional form)) 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 (make-symbol "--cl-letf-save--")) - (bound (and (memq (car place) '(symbol-value symbol-function)) - (make-symbol "--cl-letf-bound--"))) - (temp (and (not (cl-const-expr-p value)) (cdr bindings) - (make-symbol "--cl-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)))) + `(let ,bindings ,@body) + (cl--letf bindings () () body))) ;;;###autoload -(defmacro letf* (bindings &rest body) +(defmacro cl-letf* (bindings &rest 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. - -\(fn ((PLACE VALUE) ...) BODY...)" - (if (null bindings) - (cons 'progn body) - (setq bindings (reverse bindings)) - (while bindings - (setq body (list (list* 'letf (list (pop bindings)) body)))) - (car body))) +Like `cl-letf' but where the bindings are performed one at a time, +rather than all at the end (i.e. like `let*' rather than like `let')." + (declare (indent 1) (debug cl-letf)) + (dolist (binding (reverse bindings)) + (setq body (list `(cl-letf (,binding) ,@body)))) + (macroexp-progn body)) ;;;###autoload -(defmacro callf (func place &rest args) +(defmacro cl-callf (func place &rest 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'. - -\(fn FUNC PLACE ARGS...)" - (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)))))) +or any generalized variable allowed by `setf'." + (declare (indent 2) (debug (cl-function place &rest form))) + (gv-letplace (getter setter) place + (let* ((rargs (cons getter args))) + (funcall setter + (if (symbolp func) (cons func rargs) + `(funcall #',func ,@rargs)))))) ;;;###autoload -(defmacro callf2 (func arg1 place &rest args) +(defmacro cl-callf2 (func arg1 place &rest args) "Set PLACE to (FUNC ARG1 PLACE ARGS...). -Like `callf', but PLACE is the second argument of FUNC, not the first. +Like `cl-callf', but PLACE is the second argument of FUNC, not the first. \(fn FUNC ARG1 PLACE ARGS...)" - (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)) (make-symbol "--cl-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))))))) - -;;;###autoload -(defmacro define-modify-macro (name arglist func &optional doc) - "Define a `setf'-like modify macro. -If NAME is called, it combines its PLACE argument with the other arguments -from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" - (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) - (let ((place (make-symbol "--cl-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))))) - + (declare (indent 3) (debug (cl-function form place &rest form))) + (if (and (cl--safe-expr-p arg1) (cl--simple-expr-p place) (symbolp func)) + `(setf ,place (,func ,arg1 ,place ,@args)) + (macroexp-let2 nil a1 arg1 + (gv-letplace (getter setter) place + (let* ((rargs (cl-list* a1 getter args))) + (funcall setter + (if (symbolp func) (cons func rargs) + `(funcall #',func ,@rargs)))))))) ;;; Structures. ;;;###autoload -(defmacro defstruct (struct &rest descs) +(defmacro cl-defstruct (struct &rest descs) "Define a struct type. This macro defines a new data type called NAME that stores data in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME' @@ -2197,8 +2167,9 @@ copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'. You can use the accessors to set the corresponding slots, via `setf'. NAME may instead take the form (NAME OPTIONS...), where each -OPTION is either a single keyword or (KEYWORD VALUE). -See Info node `(cl)Structures' for a list of valid keywords. +OPTION is either a single keyword or (KEYWORD VALUE) where +KEYWORD can be one of :conc-name, :constructor, :copier, :predicate, +:type, :named, :initial-offset, :print-function, or :include. Each SLOT may instead take the form (SLOT SLOT-OPTS...), where SLOT-OPTS are keyword-value pairs for that slot. Currently, only @@ -2206,6 +2177,26 @@ one keyword is supported, `:read-only'. If this has a non-nil value, that slot cannot be set via `setf'. \(fn NAME SLOTS...)" + (declare (doc-string 2) (indent 1) + (debug + (&define ;Makes top-level form not be wrapped. + [&or symbolp + (gate + symbolp &rest + (&or [":conc-name" symbolp] + [":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)))) (let* ((name (if (consp struct) (car struct) struct)) (opts (cdr-safe struct)) (slots nil) @@ -2216,7 +2207,7 @@ value, that slot cannot be set via `setf'. (copier (intern (format "copy-%s" name))) (predicate (intern (format "%s-p" name))) (print-func nil) (print-auto nil) - (safety (if (cl-compiling-file) cl-optimize-safety 3)) + (safety (if (cl--compiling-file) cl-optimize-safety 3)) (include nil) (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) @@ -2227,8 +2218,8 @@ value, that slot cannot be set via `setf'. (forms nil) pred-form pred-check) (if (stringp (car descs)) - (push (list 'put (list 'quote name) '(quote structure-documentation) - (pop descs)) forms)) + (push `(put ',name 'structure-documentation + ,(pop descs)) forms)) (setq descs (cons '(cl-tag-slot) (mapcar (function (lambda (x) (if (consp x) x (list x)))) descs))) @@ -2270,15 +2261,13 @@ value, that slot cannot be set via `setf'. (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)) + (setq print-func + `(progn (funcall #',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)))))) + `(progn + (princ ,(format "#S(%s" name) cl-s)))))) (if include (let ((inc-type (get include 'cl-struct-type)) (old-descs (get include 'cl-struct-slots))) @@ -2297,9 +2286,9 @@ value, that slot cannot be set via `setf'. (if (cadr inc-type) (setq tag name named t)) (let ((incl include)) (while incl - (push (list 'pushnew (list 'quote tag) - (intern (format "cl-struct-%s-tags" incl))) - forms) + (push `(cl-pushnew ',tag + ,(intern (format "cl-struct-%s-tags" incl))) + forms) (setq incl (get incl 'cl-struct-include))))) (if type (progn @@ -2308,25 +2297,23 @@ value, that slot cannot be set via `setf'. (if named (setq tag name))) (setq type 'vector named 'true))) (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) - (push (list 'defvar tag-symbol) forms) + (push `(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)) + `(and (vectorp cl-x) + (>= (length cl-x) ,(length descs)) + (memq (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)))))) + `(memq (car-safe cl-x) ,tag-symbol) + `(and (consp cl-x) + (memq (nth ,pos cl-x) ,tag-symbol)))))) pred-check (and pred-form (> safety 0) - (if (and (eq (caadr pred-form) 'vectorp) + (if (and (eq (cl-caadr pred-form) 'vectorp) (= safety 1)) - (cons 'and (cdddr pred-form)) pred-form))) + (cons 'and (cl-cdddr pred-form)) pred-form))) (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) @@ -2334,54 +2321,60 @@ value, that slot cannot be set via `setf'. (if (memq slot '(cl-tag-slot cl-skip-slot)) (progn (push nil slots) - (push (and (eq slot 'cl-tag-slot) (list 'quote tag)) + (push (and (eq slot 'cl-tag-slot) `',tag) defaults)) (if (assq slot descp) (error "Duplicate slots named %s in %s" slot name)) (let ((accessor (intern (format "%s%s" conc-name slot)))) (push slot slots) (push (nth 1 desc) defaults) - (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))))) - (list (if (eq type 'vector) (list 'aref 'cl-x pos) - (if (= pos 0) '(car cl-x) - (list 'nth pos 'cl-x)))))) forms) + (push `(cl-defsubst ,accessor (cl-x) + ,@(and pred-check + (list `(or ,pred-check + (error "%s accessing a non-%s" + ',accessor ',name)))) + ,(if (eq type 'vector) `(aref cl-x ,pos) + (if (= pos 0) '(car cl-x) + `(nth ,pos cl-x)))) forms) (push (cons accessor t) side-eff) - (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)) - ;; If cl is loaded only for compilation, - ;; the call to cl-struct-setf-expander would - ;; cause a warning because it may not be - ;; defined at run time. Suppress that warning. - (list 'with-no-warnings - (list 'cl-struct-setf-expander 'cl-x - (list 'quote name) (list 'quote accessor) - (and pred-check (list 'quote pred-check)) - pos)))) - forms) + (if (cadr (memq :read-only (cddr desc))) + (push `(gv-define-expander ,accessor + (lambda (_cl-do _cl-x) + (error "%s is a read-only slot" ',accessor))) + forms) + ;; For normal slots, we don't need to define a setf-expander, + ;; since gv-get can use the compiler macro to get the + ;; same result. + ;; (push `(gv-define-setter ,accessor (cl-val cl-x) + ;; ;; If cl is loaded only for compilation, + ;; ;; the call to cl--struct-setf-expander would + ;; ;; cause a warning because it may not be + ;; ;; defined at run time. Suppress that warning. + ;; (progn + ;; (declare-function + ;; cl--struct-setf-expander "cl-macs" + ;; (x name accessor pred-form pos)) + ;; (cl--struct-setf-expander + ;; cl-val cl-x ',name ',accessor + ;; ,(and pred-check `',pred-check) + ;; ,pos))) + ;; forms) + ) (if print-auto (nconc print-func - (list (list 'princ (format " %s" slot) 'cl-s) - (list 'prin1 (list accessor 'cl-x) 'cl-s))))))) + (list `(princ ,(format " %s" slot) cl-s) + `(prin1 (,accessor cl-x) cl-s))))))) (setq pos (1+ pos)))) (setq slots (nreverse slots) defaults (nreverse defaults)) (and predicate pred-form - (progn (push (list 'defsubst* predicate '(cl-x) - (if (eq (car pred-form) 'and) - (append pred-form '(t)) - (list 'and pred-form t))) forms) + (progn (push `(cl-defsubst ,predicate (cl-x) + ,(if (eq (car pred-form) 'and) + (append pred-form '(t)) + `(and ,pred-form t))) forms) (push (cons predicate 'error-free) side-eff))) (and copier - (progn (push (list 'defun copier '(x) '(copy-sequence x)) forms) + (progn (push `(defun ,copier (x) (copy-sequence x)) forms) (push (cons copier t) side-eff))) (if constructor (push (list constructor @@ -2390,83 +2383,60 @@ value, that slot cannot be set via `setf'. (while constrs (let* ((name (caar constrs)) (args (cadr (pop constrs))) - (anames (cl-arglist-args args)) - (make (mapcar* (function (lambda (s d) (if (memq s anames) s d))) + (anames (cl--arglist-args args)) + (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) - (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))) + (push `(cl-defsubst ,name + (&cl-defs '(nil ,@descs) ,@args) + (,type ,@make)) forms) + (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) (push (cons name t) side-eff)))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) - (if print-func - (push (list 'push - (list 'function - (list 'lambda '(cl-x cl-s cl-n) - (list 'and pred-form print-func))) - 'custom-print-functions) forms)) - (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) - (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))))) - -;;;###autoload -(defun cl-struct-setf-expander (x name accessor pred-form pos) - (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-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))))) - (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)))) - + ;; Don't bother adding to cl-custom-print-functions since it's not used + ;; by anything anyway! + ;;(if print-func + ;; (push `(if (boundp 'cl-custom-print-functions) + ;; (push + ;; ;; The auto-generated function does not pay attention to + ;; ;; the depth argument cl-n. + ;; (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n)) + ;; (and ,pred-form ,print-func)) + ;; cl-custom-print-functions)) + ;; forms)) + (push `(setq ,tag-symbol (list ',tag)) forms) + (push `(cl-eval-when (compile load eval) + (put ',name 'cl-struct-slots ',descs) + (put ',name 'cl-struct-type ',(list type (eq named t))) + (put ',name 'cl-struct-include ',include) + (put ',name 'cl-struct-print ,print-auto) + ,@(mapcar (lambda (x) + `(put ',(car x) 'side-effect-free ',(cdr x))) + side-eff)) + forms) + `(progn ,@(nreverse (cons `',name forms))))) ;;; Types and assertions. ;;;###autoload -(defmacro deftype (name arglist &rest body) +(defmacro cl-deftype (name arglist &rest 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 ''('*) arglist) body)))) +The type name can then be used in `cl-typecase', `cl-check-type', etc." + (declare (debug cl-defmacro) (doc-string 3)) + `(cl-eval-when (compile load eval) + (put ',name 'cl-deftype-handler + (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body))))) -(defun cl-make-type-test (val type) +(defun cl--make-type-test (val type) (if (symbolp type) (cond ((get type 'cl-deftype-handler) - (cl-make-type-test val (funcall (get type 'cl-deftype-handler)))) + (cl--make-type-test val (funcall (get type 'cl-deftype-handler)))) ((memq type '(nil t)) type) ((eq type 'null) `(null ,val)) ((eq type 'atom) `(atom ,val)) - ((eq type 'float) `(floatp-safe ,val)) + ((eq type 'float) `(cl-floatp-safe ,val)) ((eq type 'real) `(numberp ,val)) ((eq type 'fixnum) `(integerp ,val)) - ;; FIXME: Should `character' accept things like ?\C-\M-a ? -stef + ;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef ((memq type '(character string-char)) `(characterp ,val)) (t (let* ((name (symbol-name type)) @@ -2474,73 +2444,77 @@ The type name can then be used in `typecase', `check-type', etc." (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) + (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler) (cdr type)))) ((memq (car 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))))))) + (delq t `(and ,(cl--make-type-test val (car type)) + ,(if (memq (cadr type) '(* nil)) t + (if (consp (cadr type)) `(> ,val ,(cl-caadr type)) + `(>= ,val ,(cadr type)))) + ,(if (memq (cl-caddr type) '(* nil)) t + (if (consp (cl-caddr type)) `(< ,val ,(cl-caaddr type)) + `(<= ,val ,(cl-caddr type))))))) ((memq (car type) '(and or not)) (cons (car type) - (mapcar (function (lambda (x) (cl-make-type-test val x))) + (mapcar (function (lambda (x) (cl--make-type-test val x))) (cdr type)))) - ((memq (car type) '(member member*)) - (list 'and (list 'member* val (list 'quote (cdr type))) t)) + ((memq (car type) '(member cl-member)) + `(and (cl-member ,val ',(cdr type)) t)) ((eq (car type) 'satisfies) (list (cadr type) val)) (t (error "Bad type spec: %s" type))))) +(defvar cl--object) ;;;###autoload -(defun typep (object type) ; See compiler macro below. +(defun cl-typep (object 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 'object type))) + (let ((cl--object object)) ;; Yuck!! + (eval (cl--make-type-test 'cl--object type)))) ;;;###autoload -(defmacro check-type (form type &optional string) +(defmacro cl-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)) + (declare (debug (place cl-type-spec &optional stringp))) + (and (or (not (cl--compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) - (let* ((temp (if (cl-simple-expr-p form 3) + (let* ((temp (if (cl--simple-expr-p form 3) form (make-symbol "--cl-var--"))) - (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))))) + (body `(or ,(cl--make-type-test temp type) + (signal 'wrong-type-argument + (list ,(or string `',type) + ,temp ',form))))) + (if (eq temp form) `(progn ,body nil) + `(let ((,temp ,form)) ,body nil))))) ;;;###autoload -(defmacro assert (form &optional show-args string &rest args) +(defmacro cl-assert (form &optional show-args string &rest args) + ;; FIXME: This is actually not compatible with Common-Lisp's `assert'. "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)) + (declare (debug (form &rest form))) + (and (or (not (cl--compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) (let ((sargs (and show-args - (delq nil (mapcar - (lambda (x) - (unless (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)))) + (delq nil (mapcar (lambda (x) + (unless (macroexp-const-p x) + x)) + (cdr form)))))) + `(progn + (or ,form + ,(if string + `(error ,string ,@sargs ,@args) + `(signal 'cl-assertion-failed + (list ',form ,@sargs)))) + nil)))) ;;; Compiler macros. ;;;###autoload -(defmacro define-compiler-macro (func args &rest body) +(defmacro cl-define-compiler-macro (func args &rest 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 @@ -2551,207 +2525,191 @@ 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." + (declare (debug cl-defmacro)) (let ((p args) (res nil)) (while (consp p) (push (pop p) res)) (setq args (nconc (nreverse 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 'progn - (list 'put (list 'quote func) '(quote byte-compile) - '(quote cl-byte-compile-compiler-macro)) - ;; This is so that describe-function can locate - ;; the macro definition. - (list 'let - (list (list - 'file - (or buffer-file-name - (and (boundp 'byte-compile-current-file) - (stringp byte-compile-current-file) - byte-compile-current-file)))) - (list 'if 'file - (list 'put (list 'quote func) - '(quote compiler-macro-file) - '(purecopy (file-name-nondirectory file))))))))) + `(cl-eval-when (compile load eval) + (put ',func 'compiler-macro + (cl-function (lambda ,(if (memq '&whole args) (delq '&whole args) + (cons '_cl-whole-arg args)) + ,@body))) + ;; This is so that describe-function can locate + ;; the macro definition. + (let ((file ,(or buffer-file-name + (and (boundp 'byte-compile-current-file) + (stringp byte-compile-current-file) + byte-compile-current-file)))) + (if file (put ',func 'compiler-macro-file + (purecopy (file-name-nondirectory file))))))) ;;;###autoload -(defun compiler-macroexpand (form) +(defun cl-compiler-macroexpand (form) + "Like `macroexpand', but for compiler macros. +Expands FORM repeatedly until no further expansion is possible. +Returns FORM unchanged if it has no compiler macro, or if it has a +macro that returns its `&whole' argument." (while (let ((func (car-safe form)) (handler nil)) (while (and (symbolp func) - (not (setq handler (get func 'cl-compiler-macro))) + (not (setq handler (get func 'compiler-macro))) (fboundp func) - (or (not (eq (car-safe (symbol-function func)) 'autoload)) - (load (nth 1 (symbol-function func))))) + (or (not (autoloadp (symbol-function func))) + (autoload-do-load (symbol-function func) 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))) +;; Optimize away unused block-wrappers. + +(defvar cl--active-block-names nil) + +(cl-define-compiler-macro cl--block-wrapper (cl-form) + (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil)) + (cl--active-block-names (cons cl-entry cl--active-block-names)) + (cl-body (macroexpand-all ;Performs compiler-macro expansions. + (cons 'progn (cddr cl-form)) + macroexpand-all-environment))) + ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able + ;; to indicate that this return value is already fully expanded. + (if (cdr cl-entry) + `(catch ,(nth 1 cl-form) ,@(cdr cl-body)) + cl-body))) + +(cl-define-compiler-macro cl--block-throw (cl-tag cl-value) + (let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names))) + (if cl-found (setcdr cl-found t))) + `(throw ,cl-tag ,cl-value)) ;;;###autoload -(defmacro defsubst* (name args &rest body) +(defmacro cl-defsubst (name args &rest 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 ...). +surrounded by (cl-block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" - (let* ((argns (cl-arglist-args args)) (p argns) + (declare (debug cl-defun) (indent 2)) + (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)) (pop p)) - (list 'progn - (if p nil ; give up if defaults refer to earlier args - (list 'define-compiler-macro name - (if (memq '&key args) - (list* '&whole 'cl-whole '&cl-quote args) - (cons '&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)))) + (unsafe (not (cl--safe-expr-p pbody)))) + (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p)) + `(progn + ,(if p nil ; give up if defaults refer to earlier args + `(cl-define-compiler-macro ,name + ,(if (memq '&key args) + `(&whole cl-whole &cl-quote ,@args) + (cons '&cl-quote args)) + (cl--defsubst-expand + ',argns '(cl-block ,name ,@body) + ;; We used to pass `simple' as + ;; (not (or unsafe (cl-expr-access-order pbody argns))) + ;; But this is much too simplistic since it + ;; does not pay attention to the argvs (and + ;; cl-expr-access-order itself is also too naive). + nil + ,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns))) + (cl-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* ((substs ()) + (lets (delq nil + (cl-mapcar (lambda (argn argv) + (if (or simple (macroexp-const-p argv)) + (progn (push (cons argn argv) substs) + (and unsafe (list argn argv))) + (list argn argv))) + argns argvs)))) + ;; FIXME: `sublis/subst' will happily substitute the symbol + ;; `argn' in places where it's not used as a reference + ;; to a variable. + ;; FIXME: `sublis/subst' will happily copy `argv' to a different + ;; scope, leading to name capture. + (setq body (cond ((null substs) body) + ((null (cdr substs)) + (cl-subst (cdar substs) (caar substs) body)) + (t (cl-sublis substs body)))) + (if lets `(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) + +(defun cl--compiler-macro-member (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)) (list 'memql a list)) + (cl--const-expr-val (nth 1 keys))))) + (cond ((eq test 'eq) `(memq ,a ,list)) + ((eq test 'equal) `(member ,a ,list)) + ((or (null keys) (eq test 'eql)) `(memql ,a ,list)) (t form)))) -(define-compiler-macro assoc* (&whole form a list &rest keys) +(defun cl--compiler-macro-assoc (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))) + (cl--const-expr-val (nth 1 keys))))) + (cond ((eq test 'eq) `(assq ,a ,list)) + ((eq test 'equal) `(assoc ,a ,list)) + ((and (macroexp-const-p a) (or (null keys) (eq test 'eql))) + (if (cl-floatp-safe (cl--const-expr-val a)) + `(assoc ,a ,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) +;;;###autoload +(defun cl--compiler-macro-adjoin (form a list &rest keys) + (if (and (cl--simple-expr-p a) (cl--simple-expr-p list) (not (memq :key keys))) - (list 'if (list* 'member* a list keys) list (list 'cons a list)) + `(if (cl-member ,a ,list ,@keys) ,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) +(defun cl--compiler-macro-get (_form 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 (make-symbol "--cl-var--"))) - (list 'let (list (list temp val)) (subst temp val res))))) - form)) + `(cl-getf (symbol-plist ,sym) ,prop ,def) + `(get ,sym ,prop))) +(cl-define-compiler-macro cl-typep (&whole form val type) + (if (macroexp-const-p type) + (macroexp-let2 macroexp-copyable-p temp val + (cl--make-type-test temp (cl--const-expr-val type))) + form)) -(mapc (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 - `(lambda (w x) - ,(if (symbolp (cadr y)) - `(list ',(cadr y) - (list ',(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) - (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) )) +(dolist (y '(cl-first cl-second cl-third cl-fourth + cl-fifth cl-sixth cl-seventh + cl-eighth cl-ninth cl-tenth + cl-rest cl-endp cl-plusp cl-minusp + cl-caaar cl-caadr cl-cadar + cl-caddr cl-cdaar cl-cdadr + cl-cddar cl-cdddr cl-caaaar + cl-caaadr cl-caadar cl-caaddr + cl-cadaar cl-cadadr cl-caddar + cl-cadddr cl-cdaaar cl-cdaadr + cl-cdadar cl-cdaddr cl-cddaar + cl-cddadr cl-cdddar cl-cddddr)) + (put y 'side-effect-free t)) ;;; Things that are inline. -(proclaim '(inline floatp-safe acons map concatenate notany notevery - cl-set-elt revappend nreconc gethash)) +(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany + cl-notevery cl--set-elt cl-revappend cl-nreconc gethash)) ;;; Things that are side-effect-free. (mapc (lambda (x) (put x 'side-effect-free t)) - '(oddp evenp signum last butlast ldiff pairlis gcd lcm - isqrt floor* ceiling* truncate* round* mod* rem* subseq - list-length get* getf)) + '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd cl-lcm + cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-subseq + cl-list-length cl-get cl-getf)) ;;; Things that are side-effect-and-error-free. (mapc (lambda (x) (put x 'side-effect-free 'error-free)) - '(eql floatp-safe list* subst acons equalp random-state-p - copy-tree sublis)) + '(eql cl-floatp-safe cl-list* cl-subst cl-acons cl-equalp cl-random-state-p + copy-tree cl-sublis)) (run-hooks 'cl-macs-load-hook) ;; Local variables: ;; byte-compile-dynamic: t -;; byte-compile-warnings: (not cl-functions) ;; generated-autoload-file: "cl-loaddefs.el" ;; End: -;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46 +(provide 'cl-macs) + ;;; cl-macs.el ends here diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 2d4a2c30be6..c0c2db0d9ae 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -1,11 +1,11 @@ -;;; cl-seq.el --- Common Lisp features, part 3 +;;; cl-seq.el --- Common Lisp features, part 3 -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -41,111 +41,101 @@ ;;; Code: -(require 'cl) - -;;; 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) +(require 'cl-lib) + +;; 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) + (declare (indent 2) (debug (sexp sexp &rest form))) + `(let* ,(mapcar + (lambda (x) + (let* ((var (if (consp x) (car x) x)) + (mem `(car (cdr (memq ',var cl-keys))))) + (if (eq var :test-not) + (setq mem `(and ,mem (setq cl-test ,mem) t))) + (if (eq var :if-not) + (setq mem `(and ,mem (setq cl-if ,mem) t))) + (list (intern + (format "cl-%s" (substring (symbol-name var) 1))) + (if (consp x) `(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))) + +(defmacro cl--check-key (x) ;Expects `cl-key' in context of generated code. + (declare (debug edebug-forms)) + `(if cl-key (funcall cl-key ,x) ,x)) + +(defmacro cl--check-test-nokey (item x) ;cl-test cl-if cl-test-not cl-if-not. + (declare (debug edebug-forms)) + `(cond + (cl-test (eq (not (funcall cl-test ,item ,x)) + cl-test-not)) + (cl-if (eq (not (funcall cl-if ,x)) cl-if-not)) + (t (eql ,item ,x)))) + +(defmacro cl--check-test (item x) ;all of the above. + (declare (debug edebug-forms)) + `(cl--check-test-nokey ,item (cl--check-key ,x))) + +(defmacro cl--check-match (x y) ;cl-key cl-test cl-test-not + (declare (debug edebug-forms)) + (setq x `(cl--check-key ,x) y `(cl--check-key ,y)) + `(if cl-test + (eq (not (funcall cl-test ,x ,y)) cl-test-not) + (eql ,x ,y))) (defvar cl-test) (defvar cl-test-not) (defvar cl-if) (defvar cl-if-not) (defvar cl-key) - ;;;###autoload -(defun reduce (cl-func cl-seq &rest cl-keys) +(defun cl-reduce (cl-func cl-seq &rest cl-keys) "Reduce two-argument FUNCTION across SEQ. \nKeywords supported: :start :end :from-end :initial-value :key \n(fn FUNCTION SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:from-end (:start 0) :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)) + (setq cl-seq (cl-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 (pop cl-seq))) + (cl-seq (cl--check-key (pop cl-seq))) (t (funcall cl-func))))) (if cl-from-end (while cl-seq - (setq cl-accum (funcall cl-func (cl-check-key (pop cl-seq)) + (setq cl-accum (funcall cl-func (cl--check-key (pop cl-seq)) cl-accum))) (while cl-seq (setq cl-accum (funcall cl-func cl-accum - (cl-check-key (pop cl-seq)))))) + (cl--check-key (pop cl-seq)))))) cl-accum))) ;;;###autoload -(defun fill (seq item &rest cl-keys) +(defun cl-fill (seq item &rest cl-keys) "Fill the elements of SEQ with ITEM. \nKeywords supported: :start :end \n(fn SEQ ITEM [KEYWORD VALUE]...)" - (cl-parsing-keywords ((:start 0) :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))) @@ -161,19 +151,19 @@ seq)) ;;;###autoload -(defun replace (cl-seq1 cl-seq2 &rest cl-keys) +(defun cl-replace (cl-seq1 cl-seq2 &rest cl-keys) "Replace the elements of SEQ1 with the elements of SEQ2. SEQ1 is destructively modified, then returned. \nKeywords supported: :start1 :end1 :start2 :end2 \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" - (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :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) + (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)) @@ -204,21 +194,21 @@ SEQ1 is destructively modified, then returned. cl-seq1)) ;;;###autoload -(defun remove* (cl-item cl-seq &rest cl-keys) +(defun cl-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. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count :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))) + (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) + (let ((cl-res (apply 'cl-delete cl-item (append cl-seq nil) (append (if cl-from-end (list :end (1+ cl-i)) (list :start cl-i)) @@ -229,20 +219,20 @@ to avoid corrupting the original 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)) + (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)))) + (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) + (nconc (cl-ldiff cl-seq cl-p) (if (= cl-count 1) (cdr cl-p) (and (cdr cl-p) - (apply 'delete* cl-item + (apply 'cl-delete cl-item (copy-sequence (cdr cl-p)) :start 0 :end (1- cl-end) :count (1- cl-count) cl-keys)))) @@ -250,30 +240,30 @@ to avoid corrupting the original SEQ. cl-seq))))) ;;;###autoload -(defun remove-if (cl-pred cl-list &rest cl-keys) +(defun cl-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. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'remove* nil cl-list :if cl-pred cl-keys)) + (apply 'cl-remove nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun remove-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-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. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'remove* nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-remove nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun delete* (cl-item cl-seq &rest cl-keys) +(defun cl-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. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count :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 @@ -281,8 +271,8 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (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))) + (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))))) @@ -293,7 +283,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (progn (while (and cl-seq (> cl-end 0) - (cl-check-test cl-item (car cl-seq)) + (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))) @@ -301,7 +291,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (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))) + (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) @@ -309,49 +299,49 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (setq cl-p (cdr cl-p))) (setq cl-end (1- cl-end))))) cl-seq) - (apply 'remove* cl-item cl-seq cl-keys))))) + (apply 'cl-remove cl-item cl-seq cl-keys))))) ;;;###autoload -(defun delete-if (cl-pred cl-list &rest cl-keys) +(defun cl-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. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'delete* nil cl-list :if cl-pred cl-keys)) + (apply 'cl-delete nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun delete-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-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. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'delete* nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-delete nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun remove-duplicates (cl-seq &rest cl-keys) +(defun cl-remove-duplicates (cl-seq &rest cl-keys) "Return a copy of SEQ with all duplicate elements removed. \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn SEQ [KEYWORD VALUE]...)" - (cl-delete-duplicates cl-seq cl-keys t)) + (cl--delete-duplicates cl-seq cl-keys t)) ;;;###autoload -(defun delete-duplicates (cl-seq &rest cl-keys) +(defun cl-delete-duplicates (cl-seq &rest cl-keys) "Remove all duplicate elements from SEQ (destructively). \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn SEQ [KEYWORD VALUE]...)" - (cl-delete-duplicates cl-seq cl-keys nil)) + (cl--delete-duplicates cl-seq cl-keys nil)) -(defun cl-delete-duplicates (cl-seq cl-keys cl-copy) +(defun cl--delete-duplicates (cl-seq cl-keys cl-copy) (if (listp cl-seq) - (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) + (cl--parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) () (if cl-from-end (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) (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))) + (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))) @@ -362,14 +352,14 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. 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))) + (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)) + (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) @@ -378,63 +368,63 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (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))) + (let ((cl-res (cl--delete-duplicates (append cl-seq nil) cl-keys nil))) (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) ;;;###autoload -(defun substitute (cl-new cl-old cl-seq &rest cl-keys) +(defun cl-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. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn NEW OLD SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count + (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))) + (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) + (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 + (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count :start cl-i cl-keys)))))) ;;;###autoload -(defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-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. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys)) + (apply 'cl-substitute cl-new nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-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. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-substitute cl-new nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) +(defun cl-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. \nKeywords supported: :test :test-not :key :count :start :end :from-end \n(fn NEW OLD SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not :count + (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)) + (if (cl--check-test cl-old (car cl-p)) (progn (setcar cl-p cl-new) (setq cl-count (1- cl-count)))) @@ -443,12 +433,12 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (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)) + (if (cl--check-test cl-old (elt cl-seq cl-end)) (progn - (cl-set-elt cl-seq cl-end cl-new) + (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)) + (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)))) @@ -456,63 +446,63 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. cl-seq)) ;;;###autoload -(defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-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. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) + (apply 'cl-nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-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. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun find (cl-item cl-seq &rest cl-keys) +(defun cl-find (cl-item cl-seq &rest cl-keys) "Find the first occurrence of ITEM in SEQ. Return the matching ITEM, or nil if not found. \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (let ((cl-pos (apply 'position cl-item cl-seq cl-keys))) + (let ((cl-pos (apply 'cl-position cl-item cl-seq cl-keys))) (and cl-pos (elt cl-seq cl-pos)))) ;;;###autoload -(defun find-if (cl-pred cl-list &rest cl-keys) +(defun cl-find-if (cl-pred cl-list &rest cl-keys) "Find the first item satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'find nil cl-list :if cl-pred cl-keys)) + (apply 'cl-find nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun find-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-find-if-not (cl-pred cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'find nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-find nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun position (cl-item cl-seq &rest cl-keys) +(defun cl-position (cl-item cl-seq &rest cl-keys) "Find the first occurrence of ITEM in SEQ. Return the index of the matching item, or nil if not found. \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not + (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))) + (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) +(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)) + (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)) @@ -520,73 +510,73 @@ Return the index of the matching item, or nil if not found. (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))))) + (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)))) + (not (cl--check-test cl-item (aref cl-seq cl-start)))) (setq cl-start (1+ cl-start))) (and (< cl-start cl-end) cl-start)))) ;;;###autoload -(defun position-if (cl-pred cl-list &rest cl-keys) +(defun cl-position-if (cl-pred cl-list &rest cl-keys) "Find the first item satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'position nil cl-list :if cl-pred cl-keys)) + (apply 'cl-position nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun position-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-position-if-not (cl-pred cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'position nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-position nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun count (cl-item cl-seq &rest cl-keys) +(defun cl-count (cl-item cl-seq &rest cl-keys) "Count the number of occurrences of ITEM in SEQ. \nKeywords supported: :test :test-not :key :start :end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :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) (pop cl-seq) (aref cl-seq cl-start))) - (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) + (if (cl--check-test cl-item cl-x) (setq cl-count (1+ cl-count))) (setq cl-start (1+ cl-start))) cl-count))) ;;;###autoload -(defun count-if (cl-pred cl-list &rest cl-keys) +(defun cl-count-if (cl-pred cl-list &rest cl-keys) "Count the number of items satisfying PREDICATE in SEQ. \nKeywords supported: :key :start :end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'count nil cl-list :if cl-pred cl-keys)) + (apply 'cl-count nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun count-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-count-if-not (cl-pred cl-list &rest cl-keys) "Count the number of items not satisfying PREDICATE in SEQ. \nKeywords supported: :key :start :end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'count nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-count nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) +(defun cl-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 shorter sequence. \nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :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)) + (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)) @@ -594,7 +584,7 @@ other, the return value indicates the end of the shorter sequence. (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) + (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)))) @@ -604,26 +594,26 @@ other, the return value indicates the end of the shorter sequence. cl-start1))))) ;;;###autoload -(defun search (cl-seq1 cl-seq2 &rest cl-keys) +(defun cl-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. \nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :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-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 + (setq cl-pos (cl--position cl-first cl-seq2 + cl-start2 cl-end2 cl-from-end)) + (apply 'cl-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)) @@ -631,14 +621,14 @@ return nil if there are no matches. (and (< cl-start2 cl-end2) cl-pos))))) ;;;###autoload -(defun sort* (cl-seq cl-pred &rest cl-keys) +(defun cl-sort (cl-seq cl-pred &rest cl-keys) "Sort the argument SEQ according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. \nKeywords supported: :key \n(fn SEQ PREDICATE [KEYWORD VALUE]...)" (if (nlistp cl-seq) - (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys)) - (cl-parsing-keywords (:key) () + (cl-replace cl-seq (apply 'cl-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) @@ -646,15 +636,15 @@ This is a destructive function; it reuses the storage of SEQ if possible. (funcall cl-key cl-y))))))))) ;;;###autoload -(defun stable-sort (cl-seq cl-pred &rest cl-keys) +(defun cl-stable-sort (cl-seq cl-pred &rest cl-keys) "Sort the argument SEQ stably according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. \nKeywords supported: :key \n(fn SEQ PREDICATE [KEYWORD VALUE]...)" - (apply 'sort* cl-seq cl-pred cl-keys)) + (apply 'cl-sort cl-seq cl-pred cl-keys)) ;;;###autoload -(defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) +(defun cl-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 PREDICATE is a `less-than' predicate on the elements. @@ -662,115 +652,117 @@ sequences, and PREDICATE is a `less-than' predicate on the elements. \n(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)" (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) () + (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))) + (if (funcall cl-pred (cl--check-key (car cl-seq2)) + (cl--check-key (car cl-seq1))) (push (pop cl-seq2) cl-res) (push (pop cl-seq1) cl-res))) - (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) + (cl-coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) -;;; See compiler macro in cl-macs.el ;;;###autoload -(defun member* (cl-item cl-list &rest cl-keys) +(defun cl-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. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" + (declare (compiler-macro cl--compiler-macro-member)) (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)))) + (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)))) +(autoload 'cl--compiler-macro-member "cl-macs") ;;;###autoload -(defun member-if (cl-pred cl-list &rest cl-keys) +(defun cl-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. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'member* nil cl-list :if cl-pred cl-keys)) + (apply 'cl-member nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun member-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-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. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'member* nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-member nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(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)) +(defun cl--adjoin (cl-item cl-list &rest cl-keys) + (if (cl--parsing-keywords (:key) t + (apply 'cl-member (cl--check-key cl-item) cl-list cl-keys)) cl-list (cons cl-item cl-list))) -;;; See compiler macro in cl-macs.el ;;;###autoload -(defun assoc* (cl-item cl-alist &rest cl-keys) +(defun cl-assoc (cl-item cl-alist &rest cl-keys) "Find the first item whose car matches ITEM in LIST. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" + (declare (compiler-macro cl--compiler-macro-assoc)) (if cl-keys - (cl-parsing-keywords (:test :test-not :key :if :if-not) () + (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)))))) + (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)))) +(autoload 'cl--compiler-macro-assoc "cl-macs") ;;;###autoload -(defun assoc-if (cl-pred cl-list &rest cl-keys) +(defun cl-assoc-if (cl-pred cl-list &rest cl-keys) "Find the first item whose car satisfies PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'assoc* nil cl-list :if cl-pred cl-keys)) + (apply 'cl-assoc nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun assoc-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-assoc-if-not (cl-pred cl-list &rest cl-keys) "Find the first item whose car does not satisfy PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'assoc* nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-assoc nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun rassoc* (cl-item cl-alist &rest cl-keys) +(defun cl-rassoc (cl-item cl-alist &rest cl-keys) "Find the first item whose cdr matches ITEM in LIST. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" (if (or cl-keys (numberp cl-item)) - (cl-parsing-keywords (:test :test-not :key :if :if-not) () + (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)))))) + (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))) ;;;###autoload -(defun rassoc-if (cl-pred cl-list &rest cl-keys) +(defun cl-rassoc-if (cl-pred cl-list &rest cl-keys) "Find the first item whose cdr satisfies PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'rassoc* nil cl-list :if cl-pred cl-keys)) + (apply 'cl-rassoc nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun rassoc-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-rassoc-if-not (cl-pred cl-list &rest cl-keys) "Find the first item whose cdr does not satisfy PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-rassoc nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun union (cl-list1 cl-list2 &rest cl-keys) +(defun cl-union (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-union operation. The resulting 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 @@ -784,14 +776,14 @@ to avoid corrupting the original LIST1 and LIST2. (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) (while cl-list2 (if (or cl-keys (numberp (car cl-list2))) - (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys)) + (setq cl-list1 (apply 'cl-adjoin (car cl-list2) cl-list1 cl-keys)) (or (memq (car cl-list2) cl-list1) (push (car cl-list2) cl-list1))) (pop cl-list2)) cl-list1))) ;;;###autoload -(defun nunion (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nunion (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-union operation. The resulting list contains all items that appear in either LIST1 or LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -799,10 +791,10 @@ whenever possible. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - (t (apply 'union cl-list1 cl-list2 cl-keys)))) + (t (apply 'cl-union cl-list1 cl-list2 cl-keys)))) ;;;###autoload -(defun intersection (cl-list1 cl-list2 &rest cl-keys) +(defun cl-intersection (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-intersection operation. The resulting 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 @@ -811,13 +803,13 @@ to avoid corrupting the original LIST1 and LIST2. \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (and cl-list1 cl-list2 (if (equal cl-list1 cl-list2) cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) + (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)) + (apply 'cl-member (cl--check-key (car cl-list2)) cl-list1 cl-keys) (memq (car cl-list2) cl-list1)) (push (car cl-list2) cl-res)) @@ -825,17 +817,17 @@ to avoid corrupting the original LIST1 and LIST2. cl-res))))) ;;;###autoload -(defun nintersection (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nintersection (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-intersection operation. The resulting 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. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys))) + (and cl-list1 cl-list2 (apply 'cl-intersection cl-list1 cl-list2 cl-keys))) ;;;###autoload -(defun set-difference (cl-list1 cl-list2 &rest cl-keys) +(defun cl-set-difference (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-difference operation. The resulting 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 @@ -843,11 +835,11 @@ to avoid corrupting the original LIST1 and LIST2. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (if (or (null cl-list1) (null cl-list2)) cl-list1 - (cl-parsing-keywords (:key) (:test :test-not) + (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)) + (apply 'cl-member (cl--check-key (car cl-list1)) cl-list2 cl-keys) (memq (car cl-list1) cl-list2)) (push (car cl-list1) cl-res)) @@ -855,7 +847,7 @@ to avoid corrupting the original LIST1 and LIST2. cl-res)))) ;;;###autoload -(defun nset-difference (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nset-difference (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-difference operation. The resulting list contains all items that appear in LIST1 but not LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -863,10 +855,10 @@ whenever possible. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (if (or (null cl-list1) (null cl-list2)) cl-list1 - (apply 'set-difference cl-list1 cl-list2 cl-keys))) + (apply 'cl-set-difference cl-list1 cl-list2 cl-keys))) ;;;###autoload -(defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) +(defun cl-set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-exclusive-or operation. The resulting list contains all items appearing in exactly one of LIST1, LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -875,11 +867,11 @@ to avoid corrupting the original LIST1 and LIST2. \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (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))))) + (t (append (apply 'cl-set-difference cl-list1 cl-list2 cl-keys) + (apply 'cl-set-difference cl-list2 cl-list1 cl-keys))))) ;;;###autoload -(defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-exclusive-or operation. The resulting list contains all items appearing in exactly one of LIST1, LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -888,136 +880,137 @@ whenever possible. \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (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))))) + (t (nconc (apply 'cl-nset-difference cl-list1 cl-list2 cl-keys) + (apply 'cl-nset-difference cl-list2 cl-list1 cl-keys))))) ;;;###autoload -(defun subsetp (cl-list1 cl-list2 &rest cl-keys) +(defun cl-subsetp (cl-list1 cl-list2 &rest cl-keys) "Return true if LIST1 is a subset of LIST2. I.e., if every element of LIST1 also appears in LIST2. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (cond ((null cl-list1) t) ((null cl-list2) nil) ((equal cl-list1 cl-list2) t) - (t (cl-parsing-keywords (:key) (:test :test-not) + (t (cl--parsing-keywords (:key) (:test :test-not) (while (and cl-list1 - (apply 'member* (cl-check-key (car cl-list1)) + (apply 'cl-member (cl--check-key (car cl-list1)) cl-list2 cl-keys)) (pop cl-list1)) (null cl-list1))))) ;;;###autoload -(defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-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. \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) + (apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) ;;;###autoload -(defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-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. \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) + (apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) ;;;###autoload -(defun nsubst (cl-new cl-old cl-tree &rest cl-keys) +(defun cl-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'). \nKeywords supported: :test :test-not :key \n(fn NEW OLD TREE [KEYWORD VALUE]...)" - (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) + (apply 'cl-nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) ;;;###autoload -(defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-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'). \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) + (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) ;;;###autoload -(defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-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'). \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) + (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) + +(defvar cl--alist) ;;;###autoload -(defun sublis (cl-alist cl-tree &rest cl-keys) +(defun cl-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. \nKeywords supported: :test :test-not :key \n(fn ALIST TREE [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (cl-sublis-rec cl-tree))) + (cl--parsing-keywords (:test :test-not :key :if :if-not) () + (let ((cl--alist cl-alist)) + (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))) +(defun cl--sublis-rec (cl-tree) ;Uses cl--alist cl-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)))) + (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)))) ;;;###autoload -(defun nsublis (cl-alist cl-tree &rest cl-keys) +(defun cl-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'. \nKeywords supported: :test :test-not :key \n(fn ALIST TREE [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key :if :if-not) () - (let ((cl-hold (list cl-tree))) - (cl-nsublis-rec cl-hold) + (cl--parsing-keywords (:test :test-not :key :if :if-not) () + (let ((cl-hold (list cl-tree)) + (cl--alist cl-alist)) + (cl--nsublis-rec cl-hold) (car cl-hold)))) -(defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if* +(defun cl--nsublis-rec (cl-tree) ;Uses cl--alist cl-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))) + (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))) + (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)))))) ;;;###autoload -(defun tree-equal (cl-x cl-y &rest cl-keys) +(defun cl-tree-equal (cl-x cl-y &rest cl-keys) "Return t if trees TREE1 and TREE2 have `eql' leaves. Atoms are compared by `eql'; cons cells are compared recursively. \nKeywords supported: :test :test-not :key \n(fn TREE1 TREE2 [KEYWORD VALUE]...)" - (cl-parsing-keywords (:test :test-not :key) () - (cl-tree-equal-rec cl-x cl-y))) + (cl--parsing-keywords (:test :test-not :key) () + (cl--tree-equal-rec cl-x cl-y))) -(defun cl-tree-equal-rec (cl-x cl-y) +(defun cl--tree-equal-rec (cl-x cl-y) ;Uses cl-key/test*. (while (and (consp cl-x) (consp cl-y) - (cl-tree-equal-rec (car cl-x) (car 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))) + (and (not (consp cl-x)) (not (consp cl-y)) (cl--check-match cl-x cl-y))) (run-hooks 'cl-seq-load-hook) ;; Local variables: ;; byte-compile-dynamic: t -;; byte-compile-warnings: (not cl-functions) ;; generated-autoload-file: "cl-loaddefs.el" ;; End: -;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c ;;; 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 f3c29b2ab1d..00000000000 --- a/lisp/emacs-lisp/cl-specs.el +++ /dev/null @@ -1,472 +0,0 @@ -;;; cl-specs.el --- Edebug specs for cl.el -*- no-byte-compile: t -*- - -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. -;; Author: Daniel LaLiberte <liberte@holonexus.org> -;; Keywords: lisp, tools, maint - -;; LCD Archive Entry: -;; cl-specs.el|Daniel LaLiberte|liberte@holonexus.org -;; |Edebug specs for cl.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 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; 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. - -;;; Code: - -(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 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 def-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)) ; different for CL -(def-edebug-spec pushnew - (form place &rest - &or [[&or ":test" ":test-not" ":key"] function-form] - [keywordp form])) -(def-edebug-spec pop (place)) ; different for CL - -(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-keys"]] - [&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-keys"]] - [&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-keys"]] - [&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*" function*) - 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" symbolp] - [":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 valid 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)) - -;; arch-tag: b29aa3c2-cf67-4af8-9ee1-318fea61b478 -;;; cl-specs.el ends here diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 798a13c361c..0ad7d4b1592 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -1,10 +1,8 @@ -;;; cl.el --- Common Lisp extensions for Emacs +;;; cl.el --- Compatibility aliases for the old CL library. -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2012-2013 Free Software Foundation, Inc. -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions ;; This file is part of GNU Emacs. @@ -24,658 +22,729 @@ ;;; 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. -;; -;; 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. - +;; This is a compatibility file which provides the old names provided by CL +;; before we cleaned up its namespace usage. ;;; Code: -(defvar cl-optimize-speed 1) -(defvar cl-optimize-safety 1) - - -;;;###autoload -(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.") +(require 'cl-lib) +(require 'macroexp) + +;; (defun cl--rename () +;; (let ((vdefs ()) +;; (fdefs ()) +;; (case-fold-search nil) +;; (files '("cl.el" "cl-macs.el" "cl-seq.el" "cl-extra.el"))) +;; (dolist (file files) +;; (with-current-buffer (find-file-noselect file) +;; (goto-char (point-min)) +;; (while (re-search-forward +;; "^(\\(def[^ \t\n]*\\) +'?\\(\\(\\sw\\|\\s_\\)+\\)" nil t) +;; (let ((name (match-string-no-properties 2)) +;; (type (match-string-no-properties 1))) +;; (unless (string-match-p "\\`cl-" name) +;; (cond +;; ((member type '("defvar" "defconst")) +;; (unless (member name vdefs) (push name vdefs))) +;; ((member type '("defun" "defsubst" "defalias" "defmacro")) +;; (unless (member name fdefs) (push name fdefs))) +;; ((member type '("def-edebug-spec" "defsetf" "define-setf-method" +;; "define-compiler-macro")) +;; nil) +;; (t (error "Unknown type %S" type)))))))) +;; (let ((re (concat "\\_<" (regexp-opt (append vdefs fdefs)) "\\_>")) +;; (conflicts ())) +;; (dolist (file files) +;; (with-current-buffer (find-file-noselect file) +;; (goto-char (point-min)) +;; (while (re-search-forward re nil t) +;; (replace-match "cl-\\&")) +;; (save-buffer)))) +;; (with-current-buffer (find-file-noselect "cl-rename.el") +;; (dolist (def vdefs) +;; (insert (format "(defvaralias '%s 'cl-%s)\n" def def))) +;; (dolist (def fdefs) +;; (insert (format "(defalias '%s 'cl-%s)\n" def def))) +;; (save-buffer)))) + +;; (defun cl--unrename () +;; ;; Taken from "Naming Conventions" node of the doc. +;; (let* ((names '(defun* defsubst* defmacro* function* member* +;; assoc* rassoc* get* remove* delete* +;; mapcar* sort* floor* ceiling* truncate* +;; round* mod* rem* random*)) +;; (files '("cl.el" "cl-lib.el" "cl-macs.el" "cl-seq.el" "cl-extra.el")) +;; (re (concat "\\_<cl-" (regexp-opt (mapcar #'symbol-name names)) +;; "\\_>"))) +;; (dolist (file files) +;; (with-current-buffer (find-file-noselect file) +;; (goto-char (point-min)) +;; (while (re-search-forward re nil t) +;; (delete-region (1- (point)) (point))) +;; (save-buffer))))) (defun cl-unload-function () "Stop unloading of the Common Lisp extensions." (message "Cannot unload the feature `cl'") - ;; stop standard unloading! + ;; Stop standard unloading! t) -;;; Generalized variables. -;; These macros are defined here so that they -;; can safely be used in .emacs files. - -(defmacro incf (place &optional 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) - "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)))) - -;; Autoloaded, but we haven't loaded cl-loaddefs yet. -(declare-function cl-do-pop "cl-macs" (place)) - -(defmacro 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) - "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. -\nKeywords supported: :test :test-not :key -\n(fn X PLACE [KEYWORD VALUE]...)" - (if (symbolp place) - (if (null keys) - `(let ((x ,x)) - (if (memql x ,place) ,place (setq ,place (cons x ,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))) - -(defsubst 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 (length 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. - -(defun cl-map-extents (&rest cl-args) - (apply 'cl-map-overlays 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. - -(defsubst values (&rest values) - "Return multiple values, Common Lisp style. -The arguments of `values' are the values -that the containing function should return." - values) - -(defsubst values-list (list) - "Return multiple values, Common Lisp style, taken from a list. -LIST specifies the list of values -that the containing function should return." - list) - -(defsubst multiple-value-list (expression) - "Return a list of the multiple values produced by EXPRESSION. -This handles multiple values in Common Lisp style, but it does not -work right when EXPRESSION calls an ordinary Emacs Lisp function -that returns just one value." - expression) - -(defsubst multiple-value-apply (function expression) - "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them. -This handles multiple values in Common Lisp style, but it does not work -right when EXPRESSION calls an ordinary Emacs Lisp function that returns just -one value." - (apply function expression)) - -(defalias 'multiple-value-call 'apply - "Apply FUNCTION to ARGUMENTS, taking multiple values into account. -This implementation only handles the case where there is only one argument.") - -(defsubst nth-value (n expression) - "Evaluate EXPRESSION to get multiple values and return the Nth one. -This handles multiple values in Common Lisp style, but it does not work -right when EXPRESSION calls an ordinary Emacs Lisp function that returns just -one value." - (nth n expression)) - -;;; Macros. - -(defvar cl-macro-environment) -(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 specifies an environment of macro -definitions to shadow the loaded ones for use in file byte-compilation. -\n(fn FORM &optional ENVIRONMENT)" - (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 'bytecomp-outbuffer) - (bufferp (symbol-value 'bytecomp-outbuffer)) - (equal (buffer-name (symbol-value 'bytecomp-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 (object) - "Return t if OBJECT is a floating point number. -On Emacs versions that lack floating-point support, this function -always returns nil." - (and (numberp object) (not (integerp object)))) - -(defun plusp (number) - "Return t if NUMBER is positive." - (> number 0)) - -(defun minusp (number) - "Return t if NUMBER is negative." - (< number 0)) - -(defun oddp (integer) - "Return t if INTEGER is odd." - (eq (logand integer 1) 1)) - -(defun evenp (integer) - "Return t if INTEGER is even." - (eq (logand integer 1) 0)) - -(defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) - -;; 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) - -(declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs)) - -(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. -\n(fn FUNCTION SEQ...)" - (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))) - -(defalias 'svref 'aref) - -;;; List functions. - -(defalias 'first 'car) -(defalias 'second 'cadr) -(defalias 'rest 'cdr) -(defalias 'endp 'null) - -(defun third (x) - "Return the third element of the list X." - (car (cdr (cdr x)))) - -(defun fourth (x) - "Return the fourth element of the list X." - (nth 3 x)) - -(defun fifth (x) - "Return the fifth element of the list X." - (nth 4 x)) - -(defun sixth (x) - "Return the sixth element of the list X." - (nth 5 x)) - -(defun seventh (x) - "Return the seventh element of the list X." - (nth 6 x)) - -(defun eighth (x) - "Return the eighth element of the list X." - (nth 7 x)) - -(defun ninth (x) - "Return the ninth element of the list X." - (nth 8 x)) - -(defun tenth (x) - "Return the tenth element of the list X." - (nth 9 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 list* (arg &rest rest) ; See compiler macro in cl-macs.el - "Return a new list with specified ARGs as elements, consed 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)))'. -\n(fn ARG...)" - (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 LIST, which may be a dotted list. -The elements of 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))) +;;; Aliases to cl-lib's features. + +(dolist (var '( + ;; loop-result-var + ;; loop-result + ;; loop-initially + ;; loop-finally + ;; loop-bindings + ;; loop-args + ;; bind-inits + ;; bind-block + ;; lambda-list-keywords + float-negative-epsilon + float-epsilon + least-negative-normalized-float + least-positive-normalized-float + least-negative-float + least-positive-float + most-negative-float + most-positive-float + ;; custom-print-functions + )) + (defvaralias var (intern (format "cl-%s" var)))) + +;; Before overwriting subr.el's `dotimes' and `dolist', let's remember +;; them under a different name, so we can use them in our implementation +;; of `dotimes' and `dolist'. +(unless (fboundp 'cl--dotimes) + (defalias 'cl--dotimes (symbol-function 'dotimes) "The non-CL `dotimes'.")) +(unless (fboundp 'cl--dolist) + (defalias 'cl--dolist (symbol-function 'dolist) "The non-CL `dolist'.")) + +(dolist (fun '( + (get* . cl-get) + (random* . cl-random) + (rem* . cl-rem) + (mod* . cl-mod) + (round* . cl-round) + (truncate* . cl-truncate) + (ceiling* . cl-ceiling) + (floor* . cl-floor) + (rassoc* . cl-rassoc) + (assoc* . cl-assoc) + (member* . cl-member) + (delete* . cl-delete) + (remove* . cl-remove) + (defsubst* . cl-defsubst) + (sort* . cl-sort) + (function* . cl-function) + (defmacro* . cl-defmacro) + (defun* . cl-defun) + (mapcar* . cl-mapcar) + + remprop + getf + tailp + list-length + nreconc + revappend + concatenate + subseq + random-state-p + make-random-state + signum + isqrt + lcm + gcd + notevery + notany + every + some + mapcon + mapcan + mapl + maplist + map + equalp + coerce + tree-equal + nsublis + sublis + nsubst-if-not + nsubst-if + nsubst + subst-if-not + subst-if + subsetp + nset-exclusive-or + set-exclusive-or + nset-difference + set-difference + nintersection + intersection + nunion + union + rassoc-if-not + rassoc-if + assoc-if-not + assoc-if + member-if-not + member-if + merge + stable-sort + search + mismatch + count-if-not + count-if + count + position-if-not + position-if + position + find-if-not + find-if + find + nsubstitute-if-not + nsubstitute-if + nsubstitute + substitute-if-not + substitute-if + substitute + delete-duplicates + remove-duplicates + delete-if-not + delete-if + remove-if-not + remove-if + replace + fill + reduce + compiler-macroexpand + define-compiler-macro + assert + check-type + typep + deftype + defstruct + callf2 + callf + letf* + ;; letf + rotatef + shiftf + remf + psetf + (define-setf-method . define-setf-expander) + declare + the + locally + multiple-value-setq + multiple-value-bind + symbol-macrolet + macrolet + progv + psetq + do-all-symbols + do-symbols + dotimes + dolist + do* + do + loop + return-from + return + block + etypecase + typecase + ecase + case + load-time-value + eval-when + destructuring-bind + gentemp + gensym + pairlis + acons + subst + adjoin + copy-list + ldiff + list* + cddddr + cdddar + cddadr + cddaar + cdaddr + cdadar + cdaadr + cdaaar + cadddr + caddar + cadadr + cadaar + caaddr + caadar + caaadr + caaaar + cdddr + cddar + cdadr + cdaar + caddr + cadar + caadr + caaar + tenth + ninth + eighth + seventh + sixth + fifth + fourth + third + endp + rest + second + first + svref + copy-seq + evenp + oddp + minusp + plusp + floatp-safe + declaim + proclaim + nth-value + multiple-value-call + multiple-value-apply + multiple-value-list + values-list + values + pushnew + decf + incf + )) + (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun))) + (intern (format "cl-%s" fun))))) + (defalias fun new))) + +;;; Features provided a bit differently in Elisp. + +;; First, the old lexical-let is now better served by `lexical-binding', tho +;; it's not 100% compatible. + +(defvar cl-closure-vars nil) +(defvar cl--function-convert-cache nil) + +(defun cl--function-convert (f) + "Special macro-expander for special cases of (function F). +The two cases that are handled are: +- closure-conversion of lambda expressions for `lexical-let'. +- renaming of F when it's a function defined via `cl-labels' or `labels'." + (require 'cl-macs) + (declare-function cl--expr-contains-any "cl-macs" (x y)) + (cond + ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked + ;; *after* handling `function', but we want to stop macroexpansion from + ;; being applied infinitely, so we use a cache to return the exact `form' + ;; being expanded even though we don't receive it. + ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache)) + ((eq (car-safe f) 'lambda) + (let ((body (mapcar (lambda (f) + (macroexpand-all f macroexpand-all-environment)) + (cddr f)))) + (if (and cl-closure-vars + (cl--expr-contains-any body cl-closure-vars)) + (let* ((new (mapcar 'cl-gensym cl-closure-vars)) + (sub (cl-pairlis cl-closure-vars new)) (decls nil)) + (while (or (stringp (car body)) + (eq (car-safe (car body)) 'interactive)) + (push (list 'quote (pop body)) decls)) + (put (car (last cl-closure-vars)) 'used t) + `(list 'lambda '(&rest --cl-rest--) + ,@(cl-sublis sub (nreverse decls)) + (list 'apply + (list 'quote + #'(lambda ,(append new (cadr f)) + ,@(cl-sublis sub body))) + ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) + cl-closure-vars) + '((quote --cl-rest--)))))) + (let* ((newf `(lambda ,(cadr f) ,@body)) + (res `(function ,newf))) + (setq cl--function-convert-cache (cons newf res)) + res)))) + (t + (let ((found (assq f macroexpand-all-environment))) + (if (and found (ignore-errors + (eq (cadr (cl-caddr found)) 'cl-labels-args))) + (cadr (cl-caddr (cl-cadddr found))) + (let ((res `(function ,f))) + (setq cl--function-convert-cache (cons f res)) + res)))))) + +(defmacro lexical-let (bindings &rest body) + "Like `let', but lexically scoped. +The main visible difference is that lambdas inside BODY will create +lexical closures as in Common Lisp. +\n(fn BINDINGS BODY)" + (declare (indent 1) (debug let)) + (let* ((cl-closure-vars cl-closure-vars) + (vars (mapcar (function + (lambda (x) + (or (consp x) (setq x (list x))) + (push (make-symbol (format "--cl-%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 + (macroexpand-all + `(cl-symbol-macrolet + ,(mapcar (lambda (x) + `(,(car x) (symbol-value ,(cl-caddr x)))) + vars) + ,@body) + (cons (cons 'function #'cl--function-convert) + macroexpand-all-environment)))) + (if (not (get (car (last cl-closure-vars)) 'used)) + ;; Turn (let ((foo (cl-gensym))) + ;; (set foo <val>) ...(symbol-value foo)...) + ;; into (let ((foo <val>)) ...(symbol-value 'foo)...). + ;; This is good because it's more efficient but it only works with + ;; dynamic scoping, since with lexical scoping we'd need + ;; (let ((foo <val>)) ...foo...). + `(progn + ,@(mapcar (lambda (x) `(defvar ,(cl-caddr x))) vars) + (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars) + ,(cl-sublis (mapcar (lambda (x) + (cons (cl-caddr x) + `',(cl-caddr x))) + vars) + ebody))) + `(let ,(mapcar (lambda (x) + (list (cl-caddr x) + `(make-symbol ,(format "--%s--" (car x))))) + vars) + (setf ,@(apply #'append + (mapcar (lambda (x) + (list `(symbol-value ,(cl-caddr x)) (cadr x))) + vars))) + ,ebody)))) + +(defmacro lexical-let* (bindings &rest body) + "Like `let*', but lexically scoped. +The main visible difference is that lambdas inside BODY, and in +successive bindings within BINDINGS, will create lexical closures +as in Common Lisp. This is similar to the behavior of `let*' in +Common Lisp. +\n(fn BINDINGS BODY)" + (declare (indent 1) (debug let)) + (if (null bindings) (cons 'progn body) + (setq bindings (reverse bindings)) + (while bindings + (setq body (list `(lexical-let (,(pop bindings)) ,@body)))) + (car body))) + +;; This should really have some way to shadow 'byte-compile properties, etc. +(defmacro flet (bindings &rest body) + "Make temporary overriding function definitions. +This is an analogue of a dynamically scoped `let' that operates on the function +cell of FUNCs rather than their value cell. +If you want the Common-Lisp style of `flet', you should use `cl-flet'. +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). + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (declare (indent 1) (debug cl-flet) + (obsolete "use either `cl-flet' or `cl-letf'." "24.3")) + `(letf ,(mapcar + (lambda (x) + (if (or (and (fboundp (car x)) + (eq (car-safe (symbol-function (car x))) 'macro)) + (cdr (assq (car x) macroexpand-all-environment))) + (error "Use `labels', not `flet', to rebind macro names")) + (let ((func `(cl-function + (lambda ,(cadr x) + (cl-block ,(car x) ,@(cddr x)))))) + (when (cl--compiling-file) + ;; Bug#411. It would be nice to fix this. + (and (get (car x) 'byte-compile) + (error "Byte-compiling a redefinition of `%s' \ +will not work - use `labels' instead" (symbol-name (car x)))) + ;; FIXME This affects the rest of the file, when it + ;; should be restricted to the flet body. + (and (boundp 'byte-compile-function-environment) + (push (cons (car x) (eval func)) + byte-compile-function-environment))) + (list `(symbol-function ',(car x)) func))) + bindings) + ,@body)) + +(defmacro labels (bindings &rest body) + "Make temporary function bindings. +Like `cl-labels' except that the lexical scoping is handled via `lexical-let' +rather than relying on `lexical-binding'." + (declare (indent 1) (debug cl-flet) (obsolete cl-labels "24.3")) + (let ((vars nil) (sets nil) (newenv macroexpand-all-environment)) + (dolist (binding bindings) + ;; It's important that (not (eq (symbol-name var1) (symbol-name var2))) + ;; because these var's *names* get added to the macro-environment. + (let ((var (make-symbol (format "--cl-%s--" (car binding))))) + (push var vars) + (push `(cl-function (lambda . ,(cdr binding))) sets) + (push var sets) + (push (cons (car binding) + `(lambda (&rest cl-labels-args) + (cl-list* 'funcall ',var + cl-labels-args))) + newenv))) + (macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) newenv))) + +;; Generalized variables are provided by gv.el, but some details are +;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we +;; still need to support old users of cl.el. + +(defmacro cl--symbol-function (symbol) + "Like `symbol-function' but return `cl--unbound' if not bound." + ;; (declare (gv-setter (lambda (store) + ;; `(if (eq ,store 'cl--unbound) + ;; (fmakunbound ,symbol) (fset ,symbol ,store))))) + `(if (fboundp ,symbol) (symbol-function ,symbol) 'cl--unbound)) +(gv-define-setter cl--symbol-function (store symbol) + `(if (eq ,store 'cl--unbound) (fmakunbound ,symbol) (fset ,symbol ,store))) + +(defmacro letf (bindings &rest body) + "Dynamically scoped let-style bindings for places. +For more details, see `cl-letf'. This macro behaves like that one +in almost every respect (apart from details that relate to some +deprecated usage of `symbol-function' in place forms)." ; bug#12760 + (declare (indent 1) (debug cl-letf)) + ;; Like cl-letf, but with special handling of symbol-function. + `(cl-letf ,(mapcar (lambda (x) (if (eq (car-safe (car x)) 'symbol-function) + `((cl--symbol-function ,@(cdar x)) ,@(cdr x)) + x)) + bindings) + ,@body)) + +(defun cl--gv-adapt (cl-gv do) + ;; This function is used by all .elc files that use define-setf-expander and + ;; were compiled with Emacs>=24.3. + (let ((vars (nth 0 cl-gv)) + (vals (nth 1 cl-gv)) + (binds ()) + (substs ())) + ;; Use cl-sublis as was done in cl-setf-do-modify. + (while vars + (if (macroexp-copyable-p (car vals)) + (push (cons (pop vars) (pop vals)) substs) + (push (list (pop vars) (pop vals)) binds))) + (macroexp-let* + binds + (funcall do (cl-sublis substs (nth 4 cl-gv)) + ;; We'd like to do something like + ;; (lambda ,(nth 2 cl-gv) ,(nth 3 cl-gv)). + (lambda (exp) + (macroexp-let2 macroexp-copyable-p v exp + (cl-sublis (cons (cons (car (nth 2 cl-gv)) v) + substs) + (nth 3 cl-gv)))))))) + +(defmacro define-setf-expander (name arglist &rest body) + "Define a `setf' method. +This method shows how to handle `setf's to places of the form +\(NAME ARGS...). The argument forms ARGS are bound according to +ARGLIST, as if NAME were going to be expanded as a macro, then +the BODY forms are executed and must return a list of five elements: +a temporary-variables list, a value-forms list, a store-variables list +\(of length one), a store-form, and an access- form. + +See `gv-define-expander', and `gv-define-setter' for better and +simpler ways to define setf-methods." + (declare (debug + (&define name cl-lambda-list cl-declarations-or-string def-body))) + `(progn + ,@(if (stringp (car body)) + (list `(put ',name 'setf-documentation ,(pop body)))) + (gv-define-expander ,name + (cl-function + (lambda (do ,@arglist) + (cl--gv-adapt (progn ,@body) do)))))) + +(defmacro defsetf (name arg1 &rest args) + "Define a `setf' method. +This macro is an easy-to-use substitute for `define-setf-expander' +that works well for simple place forms. + +In the simple `defsetf' form, `setf's of the form (setf (NAME +ARGS...) VAL) are transformed to function or macro calls of the +form (FUNC ARGS... VAL). For example: + + (defsetf aref aset) + +You can replace this form with `gv-define-simple-setter'. + +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. +For example: + + (defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v)) + +You can replace this form with `gv-define-setter'. + +\(fn NAME [FUNC | ARGLIST (STORE) BODY...])" + (declare (debug + (&define name + [&or [symbolp &optional stringp] + [cl-lambda-list (symbolp)]] + cl-declarations-or-string def-body))) + (if (and (listp arg1) (consp args)) + ;; Like `gv-define-setter' but with `cl-function'. + `(gv-define-expander ,name + (lambda (do &rest args) + (gv--defsetter ',name + (cl-function + (lambda (,@(car args) ,@arg1) ,@(cdr args))) + do args))) + `(gv-define-simple-setter ,name ,arg1 ,(car args)))) + +;; FIXME: CL used to provide a setf method for `apply', but I haven't been able +;; to find a case where it worked. The code below tries to handle it as well. +;; (defun cl--setf-apply (form last-witness last) +;; (cond +;; ((not (consp form)) form) +;; ((eq (ignore-errors (car (last form))) last-witness) +;; `(apply #',(car form) ,@(butlast (cdr form)) ,last)) +;; ((and (memq (car form) '(let let*)) +;; (rassoc (list last-witness) (cadr form))) +;; (let ((rebind (rassoc (list last-witness) (cadr form)))) +;; `(,(car form) ,(remq rebind (cadr form)) +;; ,@(mapcar (lambda (form) (cl--setf-apply form (car rebind) last)) +;; (cddr form))))) +;; (t (mapcar (lambda (form) (cl--setf-apply form last-witness last)) form)))) +;; (gv-define-setter apply (val fun &rest args) +;; (pcase fun (`#',(and (pred symbolp) f) (setq fun f)) +;; (_ (error "First arg to apply in setf is not #'SYM: %S" fun))) +;; (let* ((butlast (butlast args)) +;; (last (car (last args))) +;; (last-witness (make-symbol "--cl-tailarg--")) +;; (setter (macroexpand `(setf (,fun ,@butlast ,last-witness) ,val) +;; macroexpand-all-environment))) +;; (cl--setf-apply setter last-witness last))) + + +;; FIXME: CL used to provide get-setf-method, which was used by some +;; setf-expanders, but now that we use gv.el, it is a lot more difficult +;; and in general impossible to provide get-setf-method. Hopefully, it +;; won't be needed. If needed, we'll have to do something nasty along the +;; lines of +;; (defun get-setf-method (place &optional env) +;; (let* ((witness (list 'cl-gsm)) +;; (expansion (gv-letplace (getter setter) place +;; `(,witness ,getter ,(funcall setter witness))))) +;; ...find "let prefix" of expansion, extract getter and setter from +;; ...the rest, and build the 5-tuple)) +(make-obsolete 'get-setf-method 'gv-letplace "24.3") + +(defmacro define-modify-macro (name arglist func &optional doc) + "Define a `setf'-like modify macro. +If NAME is called, it combines its PLACE argument with the other +arguments from ARGLIST using FUNC. For example: + + (define-modify-macro incf (&optional (n 1)) +) + +You can replace this macro with `gv-letplace'." + (declare (debug + (&define name cl-lambda-list ;; should exclude &key + symbolp &optional stringp))) + (if (memq '&key arglist) + (error "&key not allowed in define-modify-macro")) + (let ((place (make-symbol "--cl-place--"))) + `(cl-defmacro ,name (,place ,@arglist) + ,doc + (,(if (memq '&rest arglist) #'cl-list* #'list) + #'cl-callf ',func ,place + ,@(cl--arglist-args arglist))))) + +;;; Additional compatibility code. +;; For names that were clean but really aren't needed any more. + +(define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.3") +(define-obsolete-variable-alias 'cl-macro-environment + 'macroexpand-all-environment "24.3") +(define-obsolete-function-alias 'cl-macroexpand-all 'macroexpand-all "24.3") + +;;; Hash tables. +;; This is just kept for compatibility with code byte-compiled by Emacs-20. + +;; No idea if this might still be needed. +(defun cl-not-hash-table (x &optional y &rest _z) + (declare (obsolete nil "24.3")) + (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) + +(defvar cl-builtin-gethash (symbol-function 'gethash)) +(make-obsolete-variable 'cl-builtin-gethash nil "24.3") +(defvar cl-builtin-remhash (symbol-function 'remhash)) +(make-obsolete-variable 'cl-builtin-remhash nil "24.3") +(defvar cl-builtin-clrhash (symbol-function 'clrhash)) +(make-obsolete-variable 'cl-builtin-clrhash nil "24.3") +(defvar cl-builtin-maphash (symbol-function 'maphash)) + +(make-obsolete-variable 'cl-builtin-maphash nil "24.3") +(define-obsolete-function-alias 'cl-map-keymap 'map-keymap "24.3") +(define-obsolete-function-alias 'cl-copy-tree 'copy-tree "24.3") +(define-obsolete-function-alias 'cl-gethash 'gethash "24.3") +(define-obsolete-function-alias 'cl-puthash 'puthash "24.3") +(define-obsolete-function-alias 'cl-remhash 'remhash "24.3") +(define-obsolete-function-alias 'cl-clrhash 'clrhash "24.3") +(define-obsolete-function-alias 'cl-maphash 'maphash "24.3") +(define-obsolete-function-alias 'cl-make-hash-table 'make-hash-table "24.3") +(define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.3") +(define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.3") + +(define-obsolete-function-alias 'cl-map-keymap-recursively + 'cl--map-keymap-recursively "24.3") +(define-obsolete-function-alias 'cl-map-intervals 'cl--map-intervals "24.3") +(define-obsolete-function-alias 'cl-map-extents 'cl--map-overlays "24.3") +(define-obsolete-function-alias 'cl-set-getf 'cl--set-getf "24.3") (defun cl-maclisp-member (item list) + (declare (obsolete member "24.3")) (while (and list (not (equal item (car list)))) (setq list (cdr list))) list) -(defalias 'cl-member 'memq) ; for compatibility with old CL package - -;; Autoloaded, but we have not loaded cl-loaddefs yet. -(declare-function floor* "cl-extra" (x &optional y)) -(declare-function ceiling* "cl-extra" (x &optional y)) -(declare-function truncate* "cl-extra" (x &optional y)) -(declare-function round* "cl-extra" (x &optional y)) -(declare-function mod* "cl-extra" (x y)) - -(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. -\nKeywords supported: :test :test-not :key -\n(fn ITEM LIST [KEYWORD VALUE]...)" - (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. -\nKeywords supported: :test :test-not :key -\n(fn NEW OLD TREE [KEYWORD VALUE]...)" - (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 (key value alist) - "Add KEY and VALUE to ALIST. -Return a new list with (cons KEY VALUE) as car and ALIST as cdr." - (cons (cons key value) alist)) - -(defun pairlis (keys values &optional alist) - "Make an alist from KEYS and VALUES. -Return a new alist composed by associating KEYS to corresponding VALUES; -the process stops as soon as KEYS or VALUES run out. -If ALIST is non-nil, the new pairs are prepended to it." - (nconc (mapcar* 'cons keys values) alist)) - - -;;; Miscellaneous. - -;; Define data for indentation and edebug. -(dolist (entry - '(((defun* defmacro*) 2) - ((function*) nil - (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) - ((eval-when) 1 (sexp &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)) - ((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 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)))) - (dolist (func (car entry)) - (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))))) - -;; Autoload the other portions of the package. -;; We want to replace the basic versions of dolist, dotimes, declare below. -(fmakunbound 'dolist) -(fmakunbound 'dotimes) -(fmakunbound 'declare) -(load "cl-loaddefs" nil 'quiet) - -;; This goes here so that cl-macs can find it if it loads right now. -(provide 'cl-19) ; usage: (require 'cl-19 "cl") -(provide 'cl) - -;; Things to do after byte-compiler is loaded. - -(defvar cl-hacked-flag nil) -(defun cl-hack-byte-compiler () - (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form) - (progn - (setq cl-hacked-flag t) ; Do it first, to prevent recursion. - (load "cl-macs" nil t) - (run-hooks 'cl-hack-bytecomp-hook)))) - -;; 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. -(add-hook 'bytecomp-load-hook 'cl-hack-byte-compiler) - - -;; The following ensures that packages which expect the old-style cl.el -;; will be happy with this one. +;; Used in the expansion of the old `defstruct'. +(defun cl-struct-setf-expander (x name accessor pred-form pos) + (declare (obsolete nil "24.3")) + (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--"))) + (list (list temp) (list x) (list store) + `(progn + ,@(and pred-form + (list `(or ,(cl-subst temp 'cl-x pred-form) + (error ,(format + "%s storing a non-%s" + accessor name))))) + ,(if (eq (car (get name 'cl-struct-type)) 'vector) + `(aset ,temp ,pos ,store) + `(setcar + ,(if (<= pos 5) + (let ((xx temp)) + (while (>= (setq pos (1- pos)) 0) + (setq xx `(cdr ,xx))) + xx) + `(nthcdr ,pos ,temp)) + ,store))) + (list accessor temp)))) (provide 'cl) (run-hooks 'cl-load-hook) -;; Local variables: -;; byte-compile-dynamic: t -;; byte-compile-warnings: (not cl-functions) -;; End: - -;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851 ;;; cl.el ends here diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index b9154beda26..b3fc6fb887a 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -1,7 +1,7 @@ ;;; copyright.el --- update the copyright notice in current buffer -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1998, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1991-1995, 1998, 2001-2013 Free Software Foundation, +;; Inc. ;; Author: Daniel Pfeiffer <occitan@esperanto.org> ;; Keywords: maint, tools @@ -47,6 +47,7 @@ This is useful for ChangeLogs." :group 'copyright :type 'boolean :version "23.1") +;;;###autoload(put 'copyright-at-end-flag 'safe-local-variable 'booleanp) (defcustom copyright-regexp "\\(©\\|@copyright{}\\|[Cc]opyright\\s *:?\\s *\\(?:(C)\\)?\ @@ -66,6 +67,11 @@ someone else or to a group for which you do not work." :group 'copyright :type 'regexp) +;; The worst that can happen is a malicious regexp that overflows in +;; the regexp matcher, a minor nuisance. It's a pain to be always +;; prompted if you want to put this in a dir-locals.el. +;;;###autoload(put 'copyright-names-regexp 'safe-local-variable 'stringp) + (defcustom copyright-years-regexp "\\(\\s *\\)\\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)" "Match additional copyright notice years. @@ -73,6 +79,19 @@ The second \\( \\) construct must match the years." :group 'copyright :type 'regexp) +;; See "Copyright Notices" in maintain.info. +;; TODO? 'end only for ranges at the end, other for all ranges. +;; Minimum limit on the size of a range? +(defcustom copyright-year-ranges nil + "Non-nil if individual consecutive years should be replaced with a range. +For example: 2005, 2006, 2007, 2008 might be replaced with 2005-2008. +If you use ranges, you should add an explanatory note in a README file. +The function `copyright-fix-years' respects this variable." + :group 'copyright + :type 'boolean + :version "24.1") + +;;;###autoload(put 'copyright-year-ranges 'safe-local-variable 'booleanp) (defcustom copyright-query 'function "If non-nil, ask user before changing copyright. @@ -92,7 +111,7 @@ When this is `function', only ask when called non-interactively." ;; This is a defvar rather than a defconst, because the year can ;; change during the Emacs session. -(defvar copyright-current-year (substring (current-time-string) -4) +(defvar copyright-current-year (format-time-string "%Y") "String representing the current year.") (defsubst copyright-limit () ; re-search-forward BOUND @@ -120,76 +139,87 @@ When this is `function', only ask when called non-interactively." (< (point) (- (point-max) copyright-limit)) (> (point) (+ (point-min) copyright-limit))))) +(defun copyright-find-copyright () + "Return non-nil if a copyright header suitable for updating is found. +The header must match `copyright-regexp' and `copyright-names-regexp', if set. +This function sets the match-data that `copyright-update-year' uses." + (widen) + (goto-char (copyright-start-point)) + (condition-case err + ;; (1) Need the extra \\( \\) around copyright-regexp because we + ;; goto (match-end 1) below. See note (2) below. + (copyright-re-search (concat "\\(" copyright-regexp + "\\)\\([ \t]*\n\\)?.*\\(?:" + copyright-names-regexp "\\)") + (copyright-limit) + t) + ;; In case the regexp is rejected. This is useful because + ;; copyright-update is typically called from before-save-hook where + ;; such an error is very inconvenient for the user. + (error (message "Can't update copyright: %s" err) nil))) + +(defun copyright-find-end () + "Possibly adjust the search performed by `copyright-find-copyright'. +If the years continue onto multiple lines that are marked as comments, +skips to the end of all the years." + (while (save-excursion + (and (eq (following-char) ?,) + (progn (forward-char 1) t) + (progn (skip-chars-forward " \t") (eolp)) + comment-start-skip + (save-match-data + (forward-line 1) + (and (looking-at comment-start-skip) + (goto-char (match-end 0)))) + (looking-at-p copyright-years-regexp))) + (forward-line 1) + (re-search-forward comment-start-skip) + ;; (2) Need the extra \\( \\) so that the years are subexp 3, as + ;; they are at note (1) above. + (re-search-forward (format "\\(%s\\)" copyright-years-regexp)))) + (defun copyright-update-year (replace noquery) - (when - (condition-case err - ;; (1) Need the extra \\( \\) around copyright-regexp because we - ;; goto (match-end 1) below. See note (2) below. - (copyright-re-search (concat "\\(" copyright-regexp - "\\)\\([ \t]*\n\\)?.*\\(?:" - copyright-names-regexp "\\)") - (copyright-limit) - t) - ;; In case the regexp is rejected. This is useful because - ;; copyright-update is typically called from before-save-hook where - ;; such an error is very inconvenient for the user. - (error (message "Can't update copyright: %s" err) nil)) - (goto-char (match-end 1)) - ;; If the years are continued onto multiple lines - ;; that are marked as comments, skip to the end of the years anyway. - (while (save-excursion - (and (eq (following-char) ?,) - (progn (forward-char 1) t) - (progn (skip-chars-forward " \t") (eolp)) - comment-start-skip - (save-match-data - (forward-line 1) - (and (looking-at comment-start-skip) - (goto-char (match-end 0)))) - (looking-at-p copyright-years-regexp))) - (forward-line 1) - (re-search-forward comment-start-skip) - ;; (2) Need the extra \\( \\) so that the years are subexp 3, as - ;; they are at note (1) above. - (re-search-forward (format "\\(%s\\)" copyright-years-regexp))) - - ;; Note that `current-time-string' isn't locale-sensitive. - (setq copyright-current-year (substring (current-time-string) -4)) - (unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3)) - (substring copyright-current-year -2)) - (if (or noquery + ;; This uses the match-data from copyright-find-copyright/end. + (goto-char (match-end 1)) + (copyright-find-end) + (setq copyright-current-year (format-time-string "%Y")) + (unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3)) + (substring copyright-current-year -2)) + (if (or noquery + (save-window-excursion + (switch-to-buffer (current-buffer)) ;; Fixes some point-moving oddness (bug#2209). (save-excursion (y-or-n-p (if replace (concat "Replace copyright year(s) by " copyright-current-year "? ") (concat "Add " copyright-current-year - " to copyright? "))))) - (if replace - (replace-match copyright-current-year t t nil 3) - (let ((size (save-excursion (skip-chars-backward "0-9")))) - (if (and (eq (% (- (string-to-number copyright-current-year) - (string-to-number (buffer-substring - (+ (point) size) - (point)))) - 100) - 1) - (or (eq (char-after (+ (point) size -1)) ?-) - (eq (char-after (+ (point) size -2)) ?-))) - ;; This is a range so just replace the end part. - (delete-char size) - ;; Insert a comma with the preferred number of spaces. - (insert - (save-excursion - (if (re-search-backward "[0-9]\\( *, *\\)[0-9]" - (line-beginning-position) t) - (match-string 1) - ", "))) - ;; If people use the '91 '92 '93 scheme, do that as well. - (if (eq (char-after (+ (point) size -3)) ?') - (insert ?'))) - ;; Finally insert the new year. - (insert (substring copyright-current-year size)))))))) + " to copyright? ")))))) + (if replace + (replace-match copyright-current-year t t nil 3) + (let ((size (save-excursion (skip-chars-backward "0-9")))) + (if (and (eq (% (- (string-to-number copyright-current-year) + (string-to-number (buffer-substring + (+ (point) size) + (point)))) + 100) + 1) + (or (eq (char-after (+ (point) size -1)) ?-) + (eq (char-after (+ (point) size -2)) ?-))) + ;; This is a range so just replace the end part. + (delete-char size) + ;; Insert a comma with the preferred number of spaces. + (insert + (save-excursion + (if (re-search-backward "[0-9]\\( *, *\\)[0-9]" + (line-beginning-position) t) + (match-string 1) + ", "))) + ;; If people use the '91 '92 '93 scheme, do that as well. + (if (eq (char-after (+ (point) size -3)) ?') + (insert ?'))) + ;; Finally insert the new year. + (insert (substring copyright-current-year size))))))) ;;;###autoload (defun copyright-update (&optional arg interactivep) @@ -206,74 +236,110 @@ interactively." (and (eq copyright-query 'function) interactivep)))) (save-excursion (save-restriction - (widen) - (goto-char (copyright-start-point)) - (copyright-update-year arg noquery) - (goto-char (copyright-start-point)) - (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 - (copyright-re-search - "\\(the Free Software Foundation;\ - either \\|; a\\^u eldono \\([0-9]+\\)a, ? a\\^u (la\\^u via \\)\ -version \\([0-9]+\\), or (at" - (copyright-limit) t) - ;; Don't update if the file is already using a more recent - ;; version than the "current" one. - (< (string-to-number (match-string 3)) - (string-to-number copyright-current-gpl-version)) - (or noquery - (save-match-data - (y-or-n-p (format "Replace GPL version by %s? " - copyright-current-gpl-version)))) - (progn - (if (match-end 2) - ;; Esperanto bilingual comment in two-column.el - (replace-match copyright-current-gpl-version t t nil 2)) - (replace-match copyright-current-gpl-version t t nil 3)))) + ;; If names-regexp doesn't match, we should not mess with + ;; the years _or_ the GPL version. + ;; TODO there may be multiple copyrights we should update. + (when (copyright-find-copyright) + (copyright-update-year arg noquery) + (goto-char (copyright-start-point)) + (and copyright-current-gpl-version + ;; Match the GPL version comment in .el files. + ;; This is sensitive to line-breaks. :( + (copyright-re-search + "the Free Software Foundation[,;\n].*either version \ +\\([0-9]+\\)\\(?: of the License\\)?, or[ \n].*any later version" + (copyright-limit) t) + ;; Don't update if the file is already using a more recent + ;; version than the "current" one. + (< (string-to-number (match-string 1)) + (string-to-number copyright-current-gpl-version)) + (or noquery + (save-match-data + (goto-char (match-end 1)) + (save-window-excursion + (switch-to-buffer (current-buffer)) + (y-or-n-p + (format "Replace GPL version %s with version %s? " + (match-string-no-properties 1) + copyright-current-gpl-version))))) + (replace-match copyright-current-gpl-version t t nil 1)))) (set (make-local-variable 'copyright-update) nil))) ;; If a write-file-hook returns non-nil, the file is presumed to be written. nil)) -;; FIXME should be within 50 years of present (cf calendar). +;; FIXME heuristic should be within 50 years of present (cf calendar). ;;;###autoload (defun copyright-fix-years () "Convert 2 digit years to 4 digit years. -Uses heuristic: year >= 50 means 19xx, < 50 means 20xx." +Uses heuristic: year >= 50 means 19xx, < 50 means 20xx. +If `copyright-year-ranges' (which see) is non-nil, also +independently replaces consecutive years with a range." (interactive) - (widen) - (goto-char (copyright-start-point)) - (if (copyright-re-search copyright-regexp (copyright-limit) t) - (let ((s (match-beginning 2)) - (e (copy-marker (1+ (match-end 2)))) + ;; TODO there may be multiple copyrights we should fix. + (if (copyright-find-copyright) + (let ((s (match-beginning 3)) (p (make-marker)) - last) + ;; Not line-beg-pos, so we don't mess up leading whitespace. + (copystart (match-beginning 0)) + e last sep year prev-year first-year range-start range-end) + ;; In case years are continued over multiple, commented lines. + (goto-char (match-end 1)) + (copyright-find-end) + (setq e (copy-marker (1+ (match-end 3)))) (goto-char s) (while (re-search-forward "[0-9]+" e t) (set-marker p (point)) (goto-char (match-beginning 0)) - (let ((sep (char-before)) - (year (string-to-number (match-string 0)))) - (when (and sep - (/= (char-syntax sep) ?\s) - (/= sep ?-)) - (insert " ")) - (when (< year 100) - (insert (if (>= year 50) "19" "20")))) + (setq year (string-to-number (match-string 0))) + (and (setq sep (char-before)) + (/= (char-syntax sep) ?\s) + (/= sep ?-) + (insert " ")) + (when (< year 100) + (insert (if (>= year 50) "19" "20")) + (setq year (+ year (if (>= year 50) 1900 2000)))) (goto-char p) - (setq last p)) + (when copyright-year-ranges + ;; If the previous thing was a range, don't try to tack more on. + ;; Ie not 2000-2005 -> 2000-2005-2007 + ;; TODO should merge into existing range if possible. + (if (eq sep ?-) + (setq prev-year nil + year nil) + (if (and prev-year (= year (1+ prev-year))) + (setq range-end (point)) + (when (and first-year prev-year + (> prev-year first-year)) + (goto-char range-end) + (delete-region range-start range-end) + (insert (format "-%d" prev-year)) + (goto-char p)) + (setq first-year year + range-start (point))))) + (setq prev-year year + last p)) (when last + (when (and copyright-year-ranges + first-year prev-year + (> prev-year first-year)) + (goto-char range-end) + (delete-region range-start range-end) + (insert (format "-%d" prev-year))) (goto-char last) ;; Don't mess up whitespace after the years. (skip-chars-backward " \t") - (save-restriction - (narrow-to-region (copyright-start-point) (point)) - (let ((fill-prefix " ")) - (fill-region s last)))) + (save-restriction + (narrow-to-region copystart (point)) + ;; This is clearly wrong, eg what about comment markers? + ;;; (let ((fill-prefix " ")) + ;; TODO do not break copyright owner over lines. + (fill-region (point-min) (point-max)))) (set-marker e nil) - (set-marker p nil) - (copyright-update nil t)) + (set-marker p nil)) + ;; Simply reformatting the years is not copyrightable, so it does + ;; not seem right to call this. Also it messes with ranges. +;;; (copyright-update nil t)) (message "No copyright message"))) ;;;###autoload @@ -281,24 +347,32 @@ Uses heuristic: year >= 50 means 19xx, < 50 means 20xx." "Insert a copyright by $ORGANIZATION notice at cursor." "Company: " comment-start - "Copyright (C) " `(substring (current-time-string) -4) " by " + "Copyright (C) " `(format-time-string "%Y") " by " (or (getenv "ORGANIZATION") str) '(if (copyright-offset-too-large-p) (message "Copyright extends beyond `copyright-limit' and won't be updated automatically.")) comment-end \n) +;; TODO: recurse, exclude COPYING etc. ;;;###autoload -(defun copyright-update-directory (directory match) - "Update copyright notice for all files in DIRECTORY matching MATCH." +(defun copyright-update-directory (directory match &optional fix) + "Update copyright notice for all files in DIRECTORY matching MATCH. +If FIX is non-nil, run `copyright-fix-years' instead." (interactive "DDirectory: \nMFilenames matching (regexp): ") (dolist (file (directory-files directory t match nil)) - (message "Updating file `%s'" file) - (find-file file) - (let ((copyright-query nil)) - (copyright-update)) - (save-buffer) - (kill-buffer (current-buffer)))) + (unless (file-directory-p file) + (message "Updating file `%s'" file) + ;; FIXME we should not use find-file+save+kill. + (let ((enable-local-variables :safe) + (enable-local-eval nil)) + (find-file file)) + (let ((inhibit-read-only t)) + (if fix + (copyright-fix-years) + (copyright-update))) + (save-buffer) + (kill-buffer (current-buffer))))) (provide 'copyright) @@ -307,5 +381,4 @@ Uses heuristic: year >= 50 means 19xx, < 50 means 20xx." ;; coding: utf-8 ;; End: -;; arch-tag: b4991afb-b6b1-4590-bebe-e076d9d4aee8 ;;; copyright.el ends here diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 38a8493effd..5607c9b0698 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -1,7 +1,6 @@ ;;; crm.el --- read multiple strings with completion -;; Copyright (C) 1985, 1986, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1993-2013 Free Software Foundation, Inc. ;; Author: Sen Nagata <sen@eccosys.com> ;; Keywords: completion, minibuffer, multiple elements @@ -144,7 +143,7 @@ nil if none. The value of FLAG is used to specify the type of completion operation. A value of nil specifies `try-completion'. A value of t specifies -`all-completions'. A value of lambda specifes a test for an exact match. +`all-completions'. A value of lambda specifies a test for an exact match. For more information on STRING, PREDICATE, and FLAG, see the Elisp Reference sections on 'Programmed Completion' and 'Basic Completion @@ -321,5 +320,4 @@ INHERIT-INPUT-METHOD." (provide 'crm) -;; arch-tag: db1911d9-86c6-4a42-b32a-4910701b15a6 ;;; crm.el ends here diff --git a/lisp/emacs-lisp/cust-print.el b/lisp/emacs-lisp/cust-print.el deleted file mode 100644 index 2bc608d9bc7..00000000000 --- a/lisp/emacs-lisp/cust-print.el +++ /dev/null @@ -1,685 +0,0 @@ -;;; cust-print.el --- handles print-level and print-circle - -;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011, 2012 Free Software Foundation, Inc. - -;; Author: Daniel LaLiberte <liberte@holonexus.org> -;; Adapted-By: ESR -;; Keywords: extensions - -;; LCD Archive Entry: -;; cust-print|Daniel LaLiberte|liberte@holonexus.org -;; |Handle print-level, print-circle and more. - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; 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: - -(defgroup cust-print nil - "Handles print-level and print-circle." - :prefix "print-" - :group 'lisp - :group 'extensions) - -;; 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) - -;; Emacs 18 doesn't 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.") - -(defcustom 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." - :type '(choice (const nil) integer) - :group 'cust-print) - - -(defcustom 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." - :type 'boolean - :group 'cust-print) - - -(defcustom custom-print-vectors nil - "Non-nil if printing of vectors should obey `print-level' and `print-length'." - :type 'boolean - :group 'cust-print) - - -;; Custom printers -;;========================================================== - -(defvar 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 Emacs Lisp 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 don't 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)) - (mapc '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) - (mapc '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) - (mapc '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 &optional noescape) - "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, unless the optional -second argument NOESCAPE is non-nil. - -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 - ;; occurred during the last prin1-to-string and we are in debugger. - (with-current-buffer buf - (erase-buffer)) - ;; We must be in the current-buffer when the print occurs. - (if noescape - (custom-princ object buf) - (custom-prin1 object buf)) - (with-current-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) - -;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580 -;;; cust-print.el ends here diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 4ef28a7615a..472706d886b 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -1,7 +1,7 @@ ;;; debug.el --- debuggers and related commands for Emacs -;; Copyright (C) 1985, 1986, 1994, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1994, 2001-2013 Free Software Foundation, +;; Inc. ;; Maintainer: FSF ;; Keywords: lisp, tools, maint @@ -49,6 +49,39 @@ the middle is discarded, and just the beginning and end are displayed." :group 'debugger :version "21.1") +(defcustom debugger-bury-or-kill 'bury + "What to do with the debugger buffer when exiting `debug'. +The value affects the behavior of operations on any window +previously showing the debugger buffer. + +`nil' means that if its window is not deleted when exiting the + debugger, invoking `switch-to-prev-buffer' will usually show + the debugger buffer again. + +`append' means that if the window is not deleted, the debugger + buffer moves to the end of the window's previous buffers so + it's less likely that a future invocation of + `switch-to-prev-buffer' will switch to it. Also, it moves the + buffer to the end of the frame's buffer list. + +`bury' means that if the window is not deleted, its buffer is + removed from the window's list of previous buffers. Also, it + moves the buffer to the end of the frame's buffer list. This + value provides the most reliable remedy to not have + `switch-to-prev-buffer' switch to the debugger buffer again + without killing the buffer. + +`kill' means to kill the debugger buffer. + +The value used here is passed to `quit-restore-window'." + :type '(choice + (const :tag "Keep alive" nil) + (const :tag "Append" append) + (const :tag "Bury" bury) + (const :tag "Kill" kill)) + :group 'debugger + :version "24.3") + (defvar debug-function-list nil "List of functions currently set for debug on entry.") @@ -61,6 +94,12 @@ the middle is discarded, and just the beginning and end are displayed." (defvar debugger-old-buffer nil "This is the buffer that was current when the debugger was entered.") +(defvar debugger-previous-window nil + "This is the window last showing the debugger buffer.") + +(defvar debugger-previous-window-height nil + "The last recorded height of `debugger-previous-window'.") + (defvar debugger-previous-backtrace nil "The contents of the previous backtrace (including text properties). This is to optimize `debugger-make-xrefs'.") @@ -72,10 +111,6 @@ This is to optimize `debugger-make-xrefs'.") (defvar debugger-outer-track-mouse) (defvar debugger-outer-last-command) (defvar debugger-outer-this-command) -;; unread-command-char is obsolete, -;; but we still save and restore it -;; in case some user program still tries to set it. -(defvar debugger-outer-unread-command-char) (defvar debugger-outer-unread-command-events) (defvar debugger-outer-unread-post-input-method-events) (defvar debugger-outer-last-input-event) @@ -99,11 +134,21 @@ and `debugger-reenable' to temporarily disable debug-on-entry.") (defvar inhibit-trace) ;Not yet implemented. +(defvar debugger-args nil + "Arguments with which the debugger was called. +It is a list expected to take the form (CAUSE . REST) +where CAUSE can be: +- debug: called for entry to a flagged function. +- t: called because of debug-on-next-call. +- lambda: same thing but via `funcall'. +- exit: called because of exit of a flagged function. +- error: called because of `debug-on-error'.") + ;;;###autoload (setq debugger 'debug) ;;;###autoload (defun debug (&rest debugger-args) - "Enter debugger. To return, type \\<debugger-mode-map>`\\[debugger-continue]'. + "Enter debugger. \\<debugger-mode-map>`\\[debugger-continue]' returns from the debugger. Arguments are mainly for use when this is called from the internals of the evaluator. @@ -117,10 +162,13 @@ first will be printed into the backtrace buffer." (unless noninteractive (message "Entering debugger...")) (let (debugger-value - (debug-on-error nil) - (debug-on-quit nil) + (debugger-previous-state + (if (get-buffer "*Backtrace*") + (with-current-buffer (get-buffer "*Backtrace*") + (list major-mode (buffer-string))))) (debugger-buffer (get-buffer-create "*Backtrace*")) (debugger-old-buffer (current-buffer)) + (debugger-window nil) (debugger-step-after-exit nil) (debugger-will-be-back nil) ;; Don't keep reading from an executing kbd macro! @@ -135,8 +183,6 @@ first will be printed into the backtrace buffer." (debugger-outer-track-mouse track-mouse) (debugger-outer-last-command last-command) (debugger-outer-this-command this-command) - (debugger-outer-unread-command-char - (with-no-warnings unread-command-char)) (debugger-outer-unread-command-events unread-command-events) (debugger-outer-unread-post-input-method-events unread-post-input-method-events) @@ -168,72 +214,86 @@ first will be printed into the backtrace buffer." (or enable-recursive-minibuffers (> (minibuffer-depth) 0))) (standard-input t) (standard-output t) inhibit-redisplay - (cursor-in-echo-area nil)) + (cursor-in-echo-area nil) + (window-configuration (current-window-configuration))) (unwind-protect (save-excursion - (save-window-excursion - (with-no-warnings - (setq unread-command-char -1)) - (when (eq (car debugger-args) 'debug) - ;; Skip the frames for backtrace-debug, byte-code, - ;; and implement-debug-on-entry. - (backtrace-debug 4 t) - ;; Place an extra debug-on-exit for macro's. - (when (eq 'lambda (car-safe (cadr (backtrace-frame 4)))) - (backtrace-debug 5 t))) - (pop-to-buffer debugger-buffer) - (debugger-mode) - (debugger-setup-buffer debugger-args) - (when noninteractive - ;; If the backtrace is long, save the beginning - ;; and the end, but discard the middle. - (when (> (count-lines (point-min) (point-max)) - debugger-batch-max-lines) - (goto-char (point-min)) - (forward-line (/ 2 debugger-batch-max-lines)) - (let ((middlestart (point))) - (goto-char (point-max)) - (forward-line (- (/ 2 debugger-batch-max-lines) - debugger-batch-max-lines)) - (delete-region middlestart (point))) - (insert "...\n")) + (when (eq (car debugger-args) 'debug) + ;; Skip the frames for backtrace-debug, byte-code, + ;; and implement-debug-on-entry. + (backtrace-debug 3 t) + ;; Place an extra debug-on-exit for macro's. + (when (eq 'lambda (car-safe (cadr (backtrace-frame 3)))) + (backtrace-debug 4 t))) + (pop-to-buffer + debugger-buffer + `((display-buffer-reuse-window + display-buffer-in-previous-window) + . (,(when debugger-previous-window + `(previous-window . ,debugger-previous-window))))) + (setq debugger-window (selected-window)) + (if (eq debugger-previous-window debugger-window) + (when debugger-jumping-flag + ;; Try to restore previous height of debugger + ;; window. + (condition-case nil + (window-resize + debugger-window + (- debugger-previous-window-height + (window-total-size debugger-window))) + (error nil))) + (setq debugger-previous-window debugger-window)) + (debugger-mode) + (debugger-setup-buffer debugger-args) + (when noninteractive + ;; If the backtrace is long, save the beginning + ;; and the end, but discard the middle. + (when (> (count-lines (point-min) (point-max)) + debugger-batch-max-lines) (goto-char (point-min)) - (message "%s" (buffer-string)) - (kill-emacs -1)) + (forward-line (/ 2 debugger-batch-max-lines)) + (let ((middlestart (point))) + (goto-char (point-max)) + (forward-line (- (/ 2 debugger-batch-max-lines) + debugger-batch-max-lines)) + (delete-region middlestart (point))) + (insert "...\n")) + (goto-char (point-min)) + (message "%s" (buffer-string)) + (kill-emacs -1)) + (message "") + (let ((standard-output nil) + (buffer-read-only t)) (message "") - (let ((standard-output nil) - (buffer-read-only t)) - (message "") - ;; Make sure we unbind buffer-read-only in the right buffer. - (save-excursion - (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 0) - ;; 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 (and maybe hide it) but keep it alive. - (with-current-buffer debugger-buffer + ;; Make sure we unbind buffer-read-only in the right buffer. + (save-excursion + (recursive-edit)))) + (when (and (window-live-p debugger-window) + (eq (window-buffer debugger-window) debugger-buffer)) + ;; Record height of debugger window. + (setq debugger-previous-window-height + (window-total-size debugger-window))) + (if debugger-will-be-back + ;; Restore previous window configuration (Bug#12623). + (set-window-configuration window-configuration) + (when (and (window-live-p debugger-window) + (eq (window-buffer debugger-window) debugger-buffer)) + (progn + ;; Unshow debugger-buffer. + (quit-restore-window debugger-window debugger-bury-or-kill) + ;; Restore current buffer (Bug#12502). + (set-buffer debugger-old-buffer)))) + ;; Restore previous state of debugger-buffer in case we were + ;; in a recursive invocation of the debugger, otherwise just + ;; erase the buffer and put it into fundamental mode. + (when (buffer-live-p debugger-buffer) + (with-current-buffer debugger-buffer + (let ((inhibit-read-only t)) (erase-buffer) - (fundamental-mode) - (with-selected-window (get-buffer-window debugger-buffer 0) - (when (and (window-dedicated-p (selected-window)) - (not debugger-will-be-back)) - ;; If the window is not dedicated, burying the buffer - ;; will mean that the frame created for it is left - ;; around showing some random buffer, and next time we - ;; pop to the debugger buffer we'll create yet - ;; another frame. - ;; If debugger-will-be-back is non-nil, the frame - ;; would need to be de-iconified anyway immediately - ;; after when we re-enter the debugger, so iconifying it - ;; here would cause flashing. - ;; Drew Adams is not happy with this: he wants to frame - ;; to be left at the top-level, still working on how - ;; best to do that. - (bury-buffer)))) - (kill-buffer debugger-buffer)) + (if (null debugger-previous-state) + (fundamental-mode) + (insert (nth 1 debugger-previous-state)) + (funcall (nth 0 debugger-previous-state)))))) (with-timeout-unsuspend debugger-with-timeout-suspend) (set-match-data debugger-outer-match-data))) ;; Put into effect the modified values of these variables @@ -245,8 +305,6 @@ first will be printed into the backtrace buffer." (setq track-mouse debugger-outer-track-mouse) (setq last-command debugger-outer-last-command) (setq this-command debugger-outer-this-command) - (with-no-warnings - (setq unread-command-char debugger-outer-unread-command-char)) (setq unread-command-events debugger-outer-unread-command-events) (setq unread-post-input-method-events debugger-outer-unread-post-input-method-events) @@ -284,32 +342,33 @@ That buffer should be current already." (insert "Debugger entered") ;; 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 a function:\n")) - ;; Exiting a function. - ((eq (car debugger-args) 'exit) - (insert "--returning 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 "--Lisp error: ") - (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 - (insert ": ") - (prin1 (if (eq (car debugger-args) 'nil) - (cdr debugger-args) debugger-args) - (current-buffer)) - (insert ?\n))) + (pcase (car debugger-args) + ((or `lambda `debug) + (insert "--entering a function:\n")) + ;; Exiting a function. + (`exit + (insert "--returning 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. + (`error + (insert "--Lisp error: ") + (prin1 (nth 1 debugger-args) (current-buffer)) + (insert ?\n)) + ;; debug-on-call, when the next thing is an eval. + (`t + (insert "--beginning evaluation of function call form:\n")) + ;; User calls debug directly. + (_ + (insert ": ") + (prin1 (if (eq (car debugger-args) 'nil) + (cdr debugger-args) debugger-args) + (current-buffer)) + (insert ?\n))) ;; After any frame that uses eval-buffer, ;; insert a line that states the buffer position it's reading at. (save-excursion @@ -330,71 +389,72 @@ That buffer should be current already." "Attach cross-references to function names in the `*Backtrace*' buffer." (interactive "b") (with-current-buffer (or buffer (current-buffer)) - (setq buffer (current-buffer)) - (let ((inhibit-read-only t) - (old-end (point-min)) (new-end (point-min))) - ;; If we saved an old backtrace, find the common part - ;; between the new and the old. - ;; Compare line by line, starting from the end, - ;; because that's the part that is likely to be unchanged. - (if debugger-previous-backtrace - (let (old-start new-start (all-match t)) - (goto-char (point-max)) - (with-temp-buffer - (insert debugger-previous-backtrace) - (while (and all-match (not (bobp))) - (setq old-end (point)) - (forward-line -1) - (setq old-start (point)) - (with-current-buffer buffer - (setq new-end (point)) + (save-excursion + (setq buffer (current-buffer)) + (let ((inhibit-read-only t) + (old-end (point-min)) (new-end (point-min))) + ;; If we saved an old backtrace, find the common part + ;; between the new and the old. + ;; Compare line by line, starting from the end, + ;; because that's the part that is likely to be unchanged. + (if debugger-previous-backtrace + (let (old-start new-start (all-match t)) + (goto-char (point-max)) + (with-temp-buffer + (insert debugger-previous-backtrace) + (while (and all-match (not (bobp))) + (setq old-end (point)) (forward-line -1) - (setq new-start (point))) - (if (not (zerop - (let ((case-fold-search nil)) - (compare-buffer-substrings - (current-buffer) old-start old-end - buffer new-start new-end)))) - (setq all-match nil)))) - ;; Now new-end is the position of the start of the - ;; unchanged part in the current buffer, and old-end is - ;; the position of that same text in the saved old - ;; backtrace. But we must subtract (point-min) since strings are - ;; indexed in origin 0. - - ;; Replace the unchanged part of the backtrace - ;; with the text from debugger-previous-backtrace, - ;; since that already has the proper xrefs. - ;; With this optimization, we only need to scan - ;; the changed part of the backtrace. - (delete-region new-end (point-max)) - (goto-char (point-max)) - (insert (substring debugger-previous-backtrace - (- old-end (point-min)))) - ;; Make the unchanged part of the backtrace inaccessible - ;; so it won't be scanned. - (narrow-to-region (point-min) new-end))) - - ;; Scan the new part of the backtrace, inserting xrefs. - (goto-char (point-min)) - (while (progn - (goto-char (+ (point) 2)) - (skip-syntax-forward "^w_") - (not (eobp))) - (let* ((beg (point)) - (end (progn (skip-syntax-forward "w_") (point))) - (sym (intern-soft (buffer-substring-no-properties - beg end))) - (file (and sym (symbol-file sym 'defun)))) - (when file - (goto-char beg) - ;; help-xref-button needs to operate on something matched - ;; by a regexp, so set that up for it. - (re-search-forward "\\(\\sw\\|\\s_\\)+") - (help-xref-button 0 'help-function-def sym file))) - (forward-line 1)) - (widen)) - (setq debugger-previous-backtrace (buffer-string)))) + (setq old-start (point)) + (with-current-buffer buffer + (setq new-end (point)) + (forward-line -1) + (setq new-start (point))) + (if (not (zerop + (let ((case-fold-search nil)) + (compare-buffer-substrings + (current-buffer) old-start old-end + buffer new-start new-end)))) + (setq all-match nil)))) + ;; Now new-end is the position of the start of the + ;; unchanged part in the current buffer, and old-end is + ;; the position of that same text in the saved old + ;; backtrace. But we must subtract (point-min) since strings are + ;; indexed in origin 0. + + ;; Replace the unchanged part of the backtrace + ;; with the text from debugger-previous-backtrace, + ;; since that already has the proper xrefs. + ;; With this optimization, we only need to scan + ;; the changed part of the backtrace. + (delete-region new-end (point-max)) + (goto-char (point-max)) + (insert (substring debugger-previous-backtrace + (- old-end (point-min)))) + ;; Make the unchanged part of the backtrace inaccessible + ;; so it won't be scanned. + (narrow-to-region (point-min) new-end))) + + ;; Scan the new part of the backtrace, inserting xrefs. + (goto-char (point-min)) + (while (progn + (goto-char (+ (point) 2)) + (skip-syntax-forward "^w_") + (not (eobp))) + (let* ((beg (point)) + (end (progn (skip-syntax-forward "w_") (point))) + (sym (intern-soft (buffer-substring-no-properties + beg end))) + (file (and sym (symbol-file sym 'defun)))) + (when file + (goto-char beg) + ;; help-xref-button needs to operate on something matched + ;; by a regexp, so set that up for it. + (re-search-forward "\\(\\sw\\|\\s_\\)+") + (help-xref-button 0 'help-function-def sym file))) + (forward-line 1)) + (widen)) + (setq debugger-previous-backtrace (buffer-string))))) (defun debugger-step-through () "Proceed, stepping through subexpressions of this expression. @@ -426,6 +486,10 @@ Enter another debugger on next entry to eval, apply or funcall." 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): ") + (when (memq (car debugger-args) '(t lambda error debug)) + (error "Cannot return a value %s" + (if (eq (car debugger-args) 'error) + "from an error" "at function entrance"))) (setq debugger-value val) (princ "Returning " t) (prin1 debugger-value) @@ -514,9 +578,9 @@ Applies to the frame whose line point is on in the backtrace." (insert ? ))) (beginning-of-line)) -(put 'debugger-env-macro 'lisp-indent-function 0) (defmacro debugger-env-macro (&rest body) "Run BODY in original environment." + (declare (indent 0)) `(save-excursion (if (null (buffer-name debugger-old-buffer)) ;; old buffer deleted @@ -542,16 +606,7 @@ Applies to the frame whose line point is on in the backtrace." (cursor-in-echo-area debugger-outer-cursor-in-echo-area)) (set-match-data debugger-outer-match-data) (prog1 - (let ((save-ucc (with-no-warnings unread-command-char))) - (unwind-protect - (progn - (with-no-warnings - (setq unread-command-char debugger-outer-unread-command-char)) - (prog1 (progn ,@body) - (with-no-warnings - (setq debugger-outer-unread-command-char unread-command-char)))) - (with-no-warnings - (setq unread-command-char save-ucc)))) + (progn ,@body) (setq debugger-outer-match-data (match-data)) (setq debugger-outer-load-read-function load-read-function) (setq debugger-outer-overriding-terminal-local-map @@ -766,6 +821,7 @@ Redefining FUNCTION also cancels it." (not (debugger-special-form-p symbol)))) t nil nil (symbol-name fn))) (list (if (equal val "") fn (intern val))))) + ;; FIXME: Use advice.el. (when (debugger-special-form-p function) (error "Function %s is a special form" function)) (if (or (symbolp (symbol-function function)) @@ -776,9 +832,9 @@ Redefining FUNCTION also cancels it." ,(interactive-form (symbol-function function)) (apply ',(symbol-function function) debug-on-entry-args))) - (when (eq (car-safe (symbol-function function)) 'autoload) + (when (autoloadp (symbol-function function)) ;; The function is autoloaded. Load its real definition. - (load (cadr (symbol-function function)) nil noninteractive nil t)) + (autoload-do-load (symbol-function function) function)) (when (or (not (consp (symbol-function function))) (and (eq (car (symbol-function function)) 'macro) (not (consp (cdr (symbol-function function)))))) @@ -823,24 +879,32 @@ To specify a nil argument interactively, exit with an empty minibuffer." (message "Cancelling debug-on-entry for all functions") (mapcar 'cancel-debug-on-entry debug-function-list))) +(defun debug-arglist (definition) + ;; FIXME: copied from ad-arglist. + "Return the argument list of DEFINITION." + (require 'help-fns) + (help-function-arglist definition 'preserve-names)) + (defun debug-convert-byte-code (function) (let* ((defn (symbol-function function)) (macro (eq (car-safe defn) 'macro))) (when macro (setq defn (cdr defn))) - (unless (consp defn) - ;; Assume a compiled code object. - (let* ((contents (append defn nil)) + (when (byte-code-function-p defn) + (let* ((args (debug-arglist defn)) (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) + `((,(if (memq '&rest args) #'apply #'funcall) + ,defn + ,@(remq '&rest (remq '&optional args)))))) + (if (> (length defn) 5) + ;; The mere presence of field 5 is sufficient to make + ;; it interactive. + (push `(interactive ,(aref defn 5)) body)) + (if (and (> (length defn) 4) (aref defn 4)) ;; Use `documentation' here, to get the actual string, ;; in case the compiled function has a reference ;; to the .elc file. (setq body (cons (documentation function) body))) - (setq defn (cons 'lambda (cons (car contents) body)))) + (setq defn `(closure (t) ,args ,@body))) (when macro (setq defn (cons 'macro defn))) (fset function defn)))) @@ -849,11 +913,12 @@ To specify a nil argument interactively, exit with an empty minibuffer." (tail defn)) (when (eq (car-safe tail) 'macro) (setq tail (cdr tail))) - (if (not (eq (car-safe tail) 'lambda)) + (if (not (memq (car-safe tail) '(closure lambda))) ;; Only signal an error when we try to set debug-on-entry. ;; When we try to clear debug-on-entry, we are now done. (when flag (error "%s is not a user-defined Lisp function" function)) + (if (eq (car tail) 'closure) (setq tail (cdr tail))) (setq tail (cdr tail)) ;; Skip the docstring. (when (and (stringp (cadr tail)) (cddr tail)) @@ -863,9 +928,9 @@ To specify a nil argument interactively, exit with an empty minibuffer." (setq tail (cdr tail))) (unless (eq flag (equal (cadr tail) '(implement-debug-on-entry))) ;; Add/remove debug statement as needed. - (if flag - (setcdr tail (cons '(implement-debug-on-entry) (cdr tail))) - (setcdr tail (cddr tail))))) + (setcdr tail (if flag + (cons '(implement-debug-on-entry) (cdr tail)) + (cddr tail))))) defn)) (defun debugger-list-functions () @@ -890,5 +955,4 @@ To specify a nil argument interactively, exit with an empty minibuffer." (provide 'debug) -;; arch-tag: b6ec7047-f801-4103-9c63-d69322db9d3b ;;; debug.el ends here diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 081e34376bd..a5876ee0bda 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -1,12 +1,13 @@ ;;; derived.el --- allow inheritance of major modes ;; (formerly mode-clone.el) -;; Copyright (C) 1993, 1994, 1999, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1993-1994, 1999, 2001-2013 Free Software Foundation, +;; Inc. ;; Author: David Megginson (dmeggins@aix1.uottawa.ca) ;; Maintainer: FSF ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -90,8 +91,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;;; PRIVATE: defsubst must be defined before they are first used (defsubst derived-mode-hook-name (mode) @@ -133,10 +132,10 @@ BODY can start with a bunch of keyword arguments. The following keyword Declare the customization group that corresponds to this mode. The command `customize-mode' uses this. :syntax-table TABLE - Use TABLE instead of the default. + Use TABLE instead of the default (CHILD-syntax-table). A nil value means to simply use the same syntax-table as the parent. :abbrev-table TABLE - Use TABLE instead of the default. + Use TABLE instead of the default (CHILD-abbrev-table). A nil value means to simply use the same abbrev-table as the parent. Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode: @@ -183,11 +182,11 @@ See Info node `(elisp)Derived Modes' for more details." ;; Process the keyword args. (while (keywordp (car body)) - (case (pop body) - (:group (setq group (pop body))) - (:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil)) - (:syntax-table (setq syntax (pop body)) (setq declare-syntax nil)) - (t (pop body)))) + (pcase (pop body) + (`:group (setq group (pop body))) + (`:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil)) + (`:syntax-table (setq syntax (pop body)) (setq declare-syntax nil)) + (_ (pop body)))) (setq docstring (derived-mode-make-docstring parent child docstring syntax abbrev)) @@ -201,7 +200,7 @@ No problems result if this variable is not bound. name)))) (unless (boundp ',map) (put ',map 'definition-name ',child)) - (defvar ,map (make-sparse-keymap)) + (with-no-warnings (defvar ,map (make-sparse-keymap))) (unless (get ',map 'variable-documentation) (put ',map 'variable-documentation (purecopy ,(format "Keymap for `%s'." child)))) @@ -253,8 +252,14 @@ No problems result if this variable is not bound. `(let ((parent (char-table-parent ,syntax))) (unless (and parent (not (eq parent (standard-syntax-table)))) - (set-char-table-parent ,syntax (syntax-table))))))) - + (set-char-table-parent ,syntax (syntax-table))))) + ,(when declare-abbrev + `(unless (or (abbrev-table-get ,abbrev :parents) + ;; This can happen if the major mode defines + ;; the abbrev-table to be its parent's. + (eq ,abbrev local-abbrev-table)) + (abbrev-table-put ,abbrev :parents + (list local-abbrev-table)))))) (use-local-map ,map) ,(when syntax `(set-syntax-table ,syntax)) ,(when abbrev `(setq local-abbrev-table ,abbrev)) @@ -272,10 +277,10 @@ A mode's class is the first ancestor which is NOT a derived mode. Use the `derived-mode-parent' property of the symbol to trace backwards. Since major-modes might all derive from `fundamental-mode', this function is not very useful." + (declare (obsolete derived-mode-p "22.1")) (while (get mode 'derived-mode-parent) (setq mode (get mode 'derived-mode-parent))) mode) -(make-obsolete 'derived-mode-class 'derived-mode-p "22.1") ;;; PRIVATE @@ -456,5 +461,4 @@ Where the new table already has an entry, nothing is copied from the old one." (provide 'derived) -;; arch-tag: 630be248-47d1-4f02-afa0-8207de0ebea0 ;;; derived.el ends here diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index ae2a37875aa..dc0e55df500 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -1,7 +1,6 @@ ;;; disass.el --- disassembler for compiled Emacs Lisp code -;; Copyright (C) 1986, 1991, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1986, 1991, 2002-2013 Free Software Foundation, Inc. ;; Author: Doug Cutting <doug@csli.stanford.edu> ;; Jamie Zawinski <jwz@lucid.com> @@ -36,6 +35,8 @@ ;;; Code: +(require 'macroexp) + ;;; 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. @@ -79,11 +80,8 @@ redefine OBJECT if it is a symbol." 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 obj (autoload-do-load obj name)) + (if (eq (car-safe obj) 'macro) ;Handle macros. (setq macro t obj (cdr obj))) (if (and (listp obj) (eq (car obj) 'byte-code)) @@ -155,7 +153,7 @@ redefine OBJECT if it is a symbol." (t (insert "Uncompiled body: ") (let ((print-escape-newlines t)) - (prin1 (if (cdr obj) (cons 'progn obj) (car obj)) + (prin1 (macroexp-progn obj) (current-buffer)))))) (if interactive-p (message ""))) @@ -216,7 +214,9 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (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)) + byte-listN byte-concatN byte-insertN + byte-stack-ref byte-stack-set byte-stack-set2 + byte-discardN byte-discardN-preserve-tos)) (insert (int-to-string arg))) ((memq op '(byte-varref byte-varset byte-varbind)) (prin1 (car arg) (current-buffer))) @@ -249,10 +249,10 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." ((eq (car-safe (car-safe arg)) 'byte-code) (insert "(<byte code>...)\n") (mapc ;recurse on list of byte-code objects - '(lambda (obj) - (disassemble-1 - obj - (+ indent disassemble-recursive-indent))) + (lambda (obj) + (disassemble-1 + obj + (+ indent disassemble-recursive-indent))) arg)) (t ;; really just a constant @@ -264,5 +264,4 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (provide 'disass) -;; arch-tag: 89482fe4-a087-4761-8dc6-d771054e763a ;;; disass.el ends here diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index a6c2ee7cb44..9173d148c6a 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -1,10 +1,10 @@ ;;; easy-mmode.el --- easy definition for major and minor modes -;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1997, 2000-2013 Free Software Foundation, Inc. ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr> ;; Maintainer: Stefan Monnier <monnier@gnu.org> +;; Package: emacs ;; Keywords: extensions lisp @@ -51,8 +51,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (defun easy-mmode-pretty-mode-name (mode &optional lighter) "Turn the symbol MODE into a string intended for the user. If provided, LIGHTER will be used to help choose capitalization by, @@ -67,7 +65,8 @@ replacing its case-insensitive matches with the literal string in LIGHTER." ;; "foo-bar-minor" -> "Foo-Bar-Minor" (capitalize (replace-regexp-in-string ;; "foo-bar-minor-mode" -> "foo-bar-minor" - "-mode\\'" "" (symbol-name mode)))) + "toggle-\\|-mode\\'" "" + (symbol-name mode)))) " mode"))) (if (not (stringp lighter)) name ;; Strip leading and trailing whitespace from LIGHTER. @@ -86,16 +85,31 @@ replacing its case-insensitive matches with the literal string in LIGHTER." ;;;###autoload (defmacro define-minor-mode (mode doc &optional init-value lighter keymap &rest body) "Define a new minor mode MODE. -This defines the control variable MODE and the toggle command MODE. +This defines the toggle command MODE and (by default) a control variable +MODE (you can override this with the :variable keyword, see below). DOC is the documentation for the mode toggle command. +The defined mode command takes one optional (prefix) argument. +Interactively with no prefix argument, it toggles the mode. +A prefix argument enables the mode if the argument is positive, +and disables it otherwise. + +When called from Lisp, the mode command toggles the mode if the +argument is `toggle', disables the mode if the argument is a +non-positive integer, and enables the mode otherwise (including +if the argument is omitted or nil or a positive integer). + +If DOC is nil, give the mode command a basic doc-string +documenting what its argument does. + Optional INIT-VALUE is the initial value of the mode's variable. -Optional LIGHTER is displayed in the modeline when the mode is on. +Optional LIGHTER is displayed in the mode line when the mode is on. Optional KEYMAP is the default keymap bound to the mode keymap. If non-nil, it should be a variable name (whose value is a keymap), or an expression that returns either a keymap or a list of - arguments for `easy-mmode-define-keymap'. If KEYMAP is not a symbol, - this also defines the variable MODE-map. + arguments for `easy-mmode-define-keymap'. If you supply a KEYMAP + argument that is not a symbol, this macro defines the variable + MODE-map and gives it the value that KEYMAP specifies. BODY contains code to execute each time the mode is enabled or disabled. It is executed after toggling the mode, and before running MODE-hook. @@ -112,15 +126,28 @@ BODY contains code to execute each time the mode is enabled or disabled. buffer-local, so don't make the variable MODE buffer-local. By default, the mode is buffer-local. :init-value VAL Same as the INIT-VALUE argument. + Not used if you also specify :variable. :lighter SPEC Same as the LIGHTER argument. :keymap MAP Same as the KEYMAP argument. :require SYM Same as in `defcustom'. +:variable PLACE The location to use instead of the variable MODE to store + the state of the mode. This can be simply a different + named variable, or more generally anything that can be used + with the CL macro `setf'. PLACE can also be of the form + \(GET . SET), where GET is an expression that returns the + current state, and SET is a function that takes one argument, + the new state, and sets it. If you specify a :variable, + this function does not define a MODE variable (nor any of + the terms used in :variable). +:after-hook A single lisp form which is evaluated after the mode hooks + have been run. It should not be quoted. For example, you could write (define-minor-mode foo-mode \"If enabled, foo on you!\" :lighter \" Foo\" :require 'foo :global t :group 'hassle :version \"27.5\" ...BODY CODE...)" - (declare (debug (&define name stringp + (declare (doc-string 2) + (debug (&define name stringp [&optional [¬ keywordp] sexp &optional [¬ keywordp] sexp &optional [¬ keywordp] sexp] @@ -130,10 +157,10 @@ For example, you could write ;; Allow skipping the first three args. (cond ((keywordp init-value) - (setq body (list* init-value lighter keymap body) + (setq body `(,init-value ,lighter ,keymap ,@body) init-value nil lighter nil keymap nil)) ((keywordp lighter) - (setq body (list* lighter keymap body) lighter nil keymap nil)) + (setq body `(,lighter ,keymap ,@body) lighter nil keymap nil)) ((keywordp keymap) (push keymap body) (setq keymap nil))) (let* ((last-message (make-symbol "last-message")) @@ -146,27 +173,40 @@ For example, you could write (type nil) (extra-args nil) (extra-keywords nil) + (variable nil) ;The PLACE where the state is stored. + (setter nil) ;The function (if any) to set the mode var. + (modefun mode) ;The minor mode function name we're defining. (require t) + (after-hook nil) (hook (intern (concat mode-name "-hook"))) (hook-on (intern (concat mode-name "-on-hook"))) (hook-off (intern (concat mode-name "-off-hook"))) - keyw keymap-sym) + keyw keymap-sym tmp) ;; Check keys. (while (keywordp (setq keyw (car body))) (setq body (cdr body)) - (case keyw - (:init-value (setq init-value (pop body))) - (:lighter (setq lighter (purecopy (pop body)))) - (:global (setq globalp (pop body))) - (:extra-args (setq extra-args (pop body))) - (:set (setq set (list :set (pop body)))) - (:initialize (setq initialize (list :initialize (pop body)))) - (:group (setq group (nconc group (list :group (pop body))))) - (:type (setq type (list :type (pop body)))) - (:require (setq require (pop body))) - (:keymap (setq keymap (pop body))) - (t (push keyw extra-keywords) (push (pop body) extra-keywords)))) + (pcase keyw + (`:init-value (setq init-value (pop body))) + (`:lighter (setq lighter (purecopy (pop body)))) + (`:global (setq globalp (pop body))) + (`:extra-args (setq extra-args (pop body))) + (`:set (setq set (list :set (pop body)))) + (`:initialize (setq initialize (list :initialize (pop body)))) + (`:group (setq group (nconc group (list :group (pop body))))) + (`:type (setq type (list :type (pop body)))) + (`:require (setq require (pop body))) + (`:keymap (setq keymap (pop body))) + (`:variable (setq variable (pop body)) + (if (not (and (setq tmp (cdr-safe variable)) + (or (symbolp tmp) + (functionp tmp)))) + ;; PLACE is not of the form (GET . SET). + (setq mode variable) + (setq mode (car variable)) + (setq setter (cdr variable)))) + (`:after-hook (setq after-hook (pop body))) + (_ (push keyw extra-keywords) (push (pop body) extra-keywords)))) (setq keymap-sym (if (and keymap (symbolp keymap)) keymap (intern (concat mode-name "-map")))) @@ -182,16 +222,22 @@ For example, you could write `(:group ',(intern (replace-regexp-in-string "-mode\\'" "" mode-name))))) + ;; TODO? Mark booleans as safe if booleanp? Eg abbrev-mode. (unless type (setq type '(:type 'boolean))) `(progn ;; Define the variable to enable or disable the mode. - ,(if (not globalp) - `(progn - (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled. + ,(cond + ;; If :variable is specified, then the var will be + ;; declared elsewhere. + (variable nil) + ((not globalp) + `(progn + :autoload-end + (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled. Use the command `%s' to change this variable." pretty-name mode)) - (make-variable-buffer-local ',mode)) - + (make-variable-buffer-local ',mode))) + (t (let ((base-doc-string (concat "Non-nil if %s is enabled. See the command `%s' for a description of this minor mode." @@ -206,43 +252,41 @@ or call the function `%s'.")))) ,@group ,@type ,@(unless (eq require t) `(:require ,require)) - ,@(nreverse extra-keywords)))) + ,@(nreverse extra-keywords))))) ;; The actual function. - (defun ,mode (&optional arg ,@extra-args) + (defun ,modefun (&optional arg ,@extra-args) ,(or doc (format (concat "Toggle %s on or off. -Interactively, with no prefix argument, toggle the mode. -With universal prefix ARG turn mode on. -With zero or negative ARG turn mode off. -\\{%s}") pretty-name keymap-sym)) +With a prefix argument ARG, enable %s if ARG is +positive, and disable it otherwise. If called from Lisp, enable +the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. +\\{%s}") pretty-name pretty-name keymap-sym)) ;; Use `toggle' rather than (if ,mode 0 1) so that using ;; repeat-command still does the toggling correctly. (interactive (list (or current-prefix-arg 'toggle))) (let ((,last-message (current-message))) - (setq ,mode - (cond - ((eq arg 'toggle) (not ,mode)) - (arg (> (prefix-numeric-value arg) 0)) - (t - (if (null ,mode) t - (message - "Toggling %s off; better pass an explicit argument." - ',mode) - nil)))) + (,@(if setter `(funcall #',setter) + (list (if (symbolp mode) 'setq 'setf) mode)) + (if (eq arg 'toggle) + (not ,mode) + ;; A nil argument also means ON now. + (> (prefix-numeric-value arg) 0))) ,@body ;; The on/off hooks are here for backward compatibility only. (run-hooks ',hook (if ,mode ',hook-on ',hook-off)) (if (called-interactively-p 'any) (progn - ,(if globalp `(customize-mark-as-set ',mode)) + ,(if (and globalp (symbolp mode)) + `(customize-mark-as-set ',mode)) ;; Avoid overwriting a message shown by the body, ;; but do overwrite previous messages. (unless (and (current-message) (not (equal ,last-message (current-message)))) (message ,(format "%s %%sabled" pretty-name) - (if ,mode "en" "dis")))))) + (if ,mode "en" "dis"))))) + ,@(when after-hook `(,after-hook))) (force-mode-line-update) ;; Return the new setting. ,mode) @@ -260,9 +304,15 @@ With zero or negative ARG turn mode off. (t (error "Invalid keymap %S" m)))) ,(format "Keymap for `%s'." mode-name))) - (add-minor-mode ',mode ',lighter - ,(if keymap keymap-sym - `(if (boundp ',keymap-sym) ,keymap-sym)))))) + ,(if (not (symbolp mode)) + (if (or lighter keymap) + (error ":lighter and :keymap unsupported with mode expression %s" mode)) + `(with-no-warnings + (add-minor-mode ',mode ',lighter + ,(if keymap keymap-sym + `(if (boundp ',keymap-sym) ,keymap-sym)) + nil + ,(unless (eq mode modefun) `',modefun))))))) ;;; ;;; make global minor mode @@ -291,7 +341,7 @@ enabled, then disabling and reenabling MODE should make MODE work correctly with the current major mode. This is important to prevent problems with derived modes, that is, major modes that call another major mode in their body." - + (declare (doc-string 2)) (let* ((global-mode-name (symbol-name global-mode)) (pretty-name (easy-mmode-pretty-mode-name mode)) (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) @@ -309,10 +359,10 @@ call another major mode in their body." ;; Check keys. (while (keywordp (setq keyw (car keys))) (setq keys (cdr keys)) - (case keyw - (:group (setq group (nconc group (list :group (pop keys))))) - (:global (setq keys (cdr keys))) - (t (push keyw extra-keywords) (push (pop keys) extra-keywords)))) + (pcase keyw + (`:group (setq group (nconc group (list :group (pop keys))))) + (`:global (setq keys (cdr keys))) + (_ (push keyw extra-keywords) (push (pop keys) extra-keywords)))) (unless group ;; We might as well provide a best-guess default group. @@ -321,20 +371,24 @@ call another major mode in their body." "-mode\\'" "" (symbol-name mode)))))) `(progn - (defvar ,MODE-major-mode nil) - (make-variable-buffer-local ',MODE-major-mode) + (progn + :autoload-end + (defvar ,MODE-major-mode nil) + (make-variable-buffer-local ',MODE-major-mode)) ;; The actual global minor-mode (define-minor-mode ,global-mode ;; Very short lines to avoid too long lines in the generated ;; doc string. - ,(format "Toggle %s in every possible buffer. -With prefix ARG, turn %s on if and only if -ARG is positive. + ,(format "Toggle %s in all buffers. +With prefix ARG, enable %s if ARG is positive; +otherwise, disable it. If called from Lisp, enable the mode if +ARG is omitted or nil. + %s is enabled in all buffers where \`%s' would do it. See `%s' for more information on %s." - pretty-name pretty-global-name pretty-name turn-on - mode pretty-name) + pretty-name pretty-global-name + pretty-name turn-on mode pretty-name) :global t ,@group ,@(nreverse extra-keywords) ;; Setup hook to handle future mode changes and new buffers. @@ -342,9 +396,13 @@ See `%s' for more information on %s." (progn (add-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers) + (add-hook 'change-major-mode-after-body-hook + ',MODE-enable-in-buffers) (add-hook 'find-file-hook ',MODE-check-buffers) (add-hook 'change-major-mode-hook ',MODE-cmhh)) (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers) + (remove-hook 'change-major-mode-after-body-hook + ',MODE-enable-in-buffers) (remove-hook 'find-file-hook ',MODE-check-buffers) (remove-hook 'change-major-mode-hook ',MODE-cmhh)) @@ -365,13 +423,14 @@ See `%s' for more information on %s." (dolist (buf ,MODE-buffers) (when (buffer-live-p buf) (with-current-buffer buf - (if ,mode - (unless (eq ,MODE-major-mode major-mode) - (,mode -1) - (,turn-on) - (setq ,MODE-major-mode major-mode)) - (,turn-on) - (setq ,MODE-major-mode major-mode)))))) + (unless (eq ,MODE-major-mode major-mode) + (if ,mode + (progn + (,mode -1) + (,turn-on) + (setq ,MODE-major-mode major-mode)) + (,turn-on) + (setq ,MODE-major-mode major-mode))))))) (put ',MODE-enable-in-buffers 'definition-name ',global-mode) (defun ,MODE-check-buffers () @@ -424,13 +483,13 @@ Valid keywords and arguments are: (while args (let ((key (pop args)) (val (pop args))) - (case key - (:name (setq name val)) - (:dense (setq dense val)) - (:inherit (setq inherit val)) - (:suppress (setq suppress val)) - (:group) - (t (message "Unknown argument %s in defmap" key))))) + (pcase key + (`:name (setq name val)) + (`:dense (setq dense val)) + (`:inherit (setq inherit val)) + (`:suppress (setq suppress val)) + (`:group) + (_ (message "Unknown argument %s in defmap" key))))) (unless (keymapp m) (setq bs (append m bs)) (setq m (if dense (make-keymap name) (make-sparse-keymap name)))) @@ -521,8 +580,6 @@ BODY is executed after moving to the destination location." (when was-narrowed (,narrowfun))))))) (unless name (setq name base-name)) `(progn - (add-to-list 'debug-ignored-errors - ,(concat "^No \\(previous\\|next\\) " (regexp-quote name))) (defun ,next-sym (&optional count) ,(format "Go to the next COUNT'th %s." name) (interactive "p") @@ -533,7 +590,7 @@ BODY is executed after moving to the destination location." `(if (not (re-search-forward ,re nil t count)) (if (looking-at ,re) (goto-char (or ,(if endfun `(,endfun)) (point-max))) - (error "No next %s" ,name)) + (user-error "No next %s" ,name)) (goto-char (match-beginning 0)) (when (and (eq (current-buffer) (window-buffer (selected-window))) (called-interactively-p 'interactive)) @@ -552,12 +609,11 @@ BODY is executed after moving to the destination location." (if (< count 0) (,next-sym (- count)) ,(funcall when-narrowed `(unless (re-search-backward ,re nil t count) - (error "No previous %s" ,name))) + (user-error "No previous %s" ,name))) ,@body)) (put ',prev-sym 'definition-name ',base)))) (provide 'easy-mmode) -;; arch-tag: d48a5250-6961-4528-9cb0-3c9ea042a66a ;;; easy-mmode.el ends here diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 2ca4b716992..f33ae54bf25 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -1,10 +1,10 @@ ;;; easymenu.el --- support the easymenu interface for defining a menu -;; Copyright (C) 1994, 1996, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1996, 1998-2013 Free Software Foundation, Inc. ;; Keywords: emulations ;; Author: Richard Stallman <rms@gnu.org> +;; Package: emacs ;; This file is part of GNU Emacs. @@ -43,113 +43,103 @@ menus, turn this variable off, otherwise it is probably better to keep it on.") (if (stringp s) (intern s) s)) ;;;###autoload -(put 'easy-menu-define 'lisp-indent-function 'defun) -;;;###autoload (defmacro easy-menu-define (symbol maps doc menu) - "Define a menu bar submenu in maps MAPS, according to MENU. - -If SYMBOL is non-nil, store the menu keymap in the value of SYMBOL, -and define SYMBOL as a function to pop up the menu, with DOC as its doc string. -If SYMBOL is nil, just store the menu keymap into MAPS. - -The first element of MENU must be a string. It is the menu bar item name. -It may be followed by the following keyword argument pairs - - :filter FUNCTION + "Define a pop-up menu and/or menu bar menu specified by MENU. +If SYMBOL is non-nil, define SYMBOL as a function to pop up the +submenu defined by MENU, with DOC as its doc string. -FUNCTION is a function with one argument, the rest of menu items. -It returns the remaining items of the displayed menu. +MAPS, if non-nil, should be a keymap or a list of keymaps; add +the submenu defined by MENU to the keymap or each of the keymaps, +as a top-level menu bar item. - :visible INCLUDE +The first element of MENU must be a string. It is the menu bar +item name. It may be followed by the following keyword argument +pairs: -INCLUDE is an expression; this menu is only visible if this -expression has a non-nil value. `:included' is an alias for `:visible'. + :filter FUNCTION + FUNCTION must be a function which, if called with one + argument---the list of the other menu items---returns the + items to actually display. - :active ENABLE + :visible INCLUDE + INCLUDE is an expression. The menu is visible if the + expression evaluates to a non-nil value. `:included' is an + alias for `:visible'. -ENABLE is an expression; the menu is enabled for selection -whenever this expression's value is non-nil. + :active ENABLE + ENABLE is an expression. The menu is enabled for selection + if the expression evaluates to a non-nil value. `:enable' is + an alias for `:active'. -The rest of the elements in MENU, are menu items. +The rest of the elements in MENU are menu items. +A menu item can be a vector of three elements: -A menu item is usually a vector of three elements: [NAME CALLBACK ENABLE] + [NAME CALLBACK ENABLE] NAME is a string--the menu item name. -CALLBACK is a command to run when the item is chosen, -or a list to evaluate when the item is chosen. +CALLBACK is a command to run when the item is chosen, or an +expression to evaluate when the item is chosen. -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. +ENABLE is an expression; the item is enabled for selection if the +expression evaluates to a non-nil value. Alternatively, a menu item may have the form: - [ NAME CALLBACK [ KEYWORD ARG ] ... ] - -Where KEYWORD is one of the symbols defined below. - - :keys KEYS - -KEYS is a string; a complex keyboard equivalent to this menu item. -This is normally not needed because keyboard equivalents are usually -computed automatically. -KEYS is expanded with `substitute-command-keys' before it is used. - - :key-sequence KEYS + [ NAME CALLBACK [ KEYWORD ARG ]... ] -KEYS is nil, a string or a vector; nil or a keyboard equivalent to this -menu item. -This is a hint that will considerably speed up Emacs' first display of -a menu. Use `:key-sequence nil' when you know that this menu item has no -keyboard equivalent. +where NAME and CALLBACK have the same meanings as above, and each +optional KEYWORD and ARG pair should be one of the following: - :active ENABLE + :keys KEYS + KEYS is a string; a keyboard equivalent to the menu item. + This is normally not needed because keyboard equivalents are + usually computed automatically. KEYS is expanded with + `substitute-command-keys' before it is used. -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. + :key-sequence KEYS + KEYS is a hint for speeding up Emacs's first display of the + menu. It should be nil if you know that the menu item has no + keyboard equivalent; otherwise it should be a string or + vector specifying a keyboard equivalent for the menu item. - :visible INCLUDE + :active ENABLE + ENABLE is an expression; the item is enabled for selection + whenever this expression's value is non-nil. `:enable' is an + alias for `:active'. -INCLUDE is an expression; this item is only visible if this -expression has a non-nil value. `:included' is an alias for `:visible'. + :visible INCLUDE + INCLUDE is an expression; this item is only visible if this + expression has a non-nil value. `:included' is an alias for + `:visible'. - :label FORM + :label FORM + FORM is an expression that is dynamically evaluated and whose + value serves as the menu item's label (the default is NAME). -FORM is an expression that will be dynamically evaluated and whose -value will be used for the menu entry's text label (the default is NAME). + :suffix FORM + FORM is an expression that is dynamically evaluated and whose + value is concatenated with the menu entry's label. - :suffix FORM + :style STYLE + STYLE is a symbol describing the type of menu item; it should + be `toggle' (a checkbox), or `radio' (a radio button), or any + other value (meaning an ordinary menu item). -FORM is an expression that will be dynamically evaluated and whose -value will be concatenated to the menu entry's label. + :selected SELECTED + SELECTED is an expression; the checkbox or radio button is + selected whenever the expression's value is non-nil. - :style STYLE + :help HELP + HELP is a string, the help to display for the menu item. -STYLE is a symbol describing the type of menu item. The following are -defined: +Alternatively, a menu item can be a string. Then that string +appears in the menu as unselectable text. A string consisting +solely of dashes is displayed as a menu separator. -toggle: A checkbox. - Prepend the name with `(*) ' or `( ) ' depending on if selected or not. -radio: A radio button. - Prepend the name with `[X] ' or `[ ] ' depending on if selected or not. -button: Surround the name with `[' and `]'. Use this for an item in the - menu bar itself. -anything else means an ordinary menu item. - - :selected SELECTED - -SELECTED is an expression; the checkbox or radio button is selected -whenever this expression's value is non-nil. - - :help HELP - -HELP is a string, the help to display for the menu item. - -A menu item can be a string. Then that string appears in the menu as -unselectable text. A string consisting solely of hyphens is displayed -as a solid horizontal line. - -A menu item can be a list with the same format as MENU. This is a submenu." +Alternatively, a menu item can be a list with the same format as +MENU. This is a submenu." + (declare (indent defun) (debug (symbolp body))) `(progn ,(if symbol `(defvar ,symbol nil ,doc)) (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) @@ -163,10 +153,13 @@ This is expected to be bound to a mouse event." (prog1 (get menu 'menu-prop) (setq menu (symbol-function menu)))))) (cons 'menu-item - (cons (or item-name - (if (keymapp menu) - (keymap-prompt menu)) - "") + (cons (if (eq :label (car props)) + (prog1 (cadr props) + (setq props (cddr props))) + (or item-name + (if (keymapp menu) + (keymap-prompt menu)) + "")) (cons menu props))))) ;;;###autoload @@ -232,15 +225,14 @@ possibly preceded by keyword pairs as described in `easy-menu-define'." (keywordp (setq keyword (car menu-items)))) (setq arg (cadr menu-items)) (setq menu-items (cddr menu-items)) - (cond - ((eq keyword :filter) + (pcase keyword + (`:filter (setq filter `(lambda (menu) (easy-menu-filter-return (,arg menu) ,menu-name)))) - ((eq keyword :active) (setq enable (or arg ''nil))) - ((eq keyword :label) (setq label arg)) - ((eq keyword :help) (setq help arg)) - ((or (eq keyword :included) (eq keyword :visible)) - (setq visible (or arg ''nil))))) + ((or `:enable `:active) (setq enable (or arg ''nil))) + (`:label (setq label arg)) + (`:help (setq help arg)) + ((or `:included `:visible) (setq visible (or arg ''nil))))) (if (equal visible ''nil) nil ; Invisible menu entry, return nil. (if (and visible (not (easy-menu-always-true-p visible))) @@ -249,14 +241,14 @@ possibly preceded by keyword pairs as described in `easy-menu-define'." (setq prop (cons :enable (cons enable prop)))) (if filter (setq prop (cons :filter (cons filter prop)))) (if help (setq prop (cons :help (cons help prop)))) - (if label (setq prop (cons nil (cons label prop)))) - (if filter - ;; The filter expects the menu in its XEmacs form and the pre-filter - ;; form will only be passed to the filter anyway, so we'd better - ;; not convert it at all (it will be converted on the fly by - ;; easy-menu-filter-return). - (setq menu menu-items) - (setq menu (append menu (mapcar 'easy-menu-convert-item menu-items)))) + (if label (setq prop (cons :label (cons label prop)))) + (setq menu (if filter + ;; The filter expects the menu in its XEmacs form and the + ;; pre-filter form will only be passed to the filter + ;; anyway, so we'd better not convert it at all (it will + ;; be converted on the fly by easy-menu-filter-return). + menu-items + (append menu (mapcar 'easy-menu-convert-item menu-items)))) (when prop (setq menu (easy-menu-make-symbol menu 'noexp)) (put menu 'menu-prop prop)) @@ -312,7 +304,7 @@ ITEM defines an item as in `easy-menu-define'." ;; Invisible menu item. Don't insert into keymap. (setq remove t) (when (and (symbolp command) (setq prop (get command 'menu-prop))) - (when (null (car prop)) + (when (eq :label (car prop)) (setq label (cadr prop)) (setq prop (cddr prop))) (setq command (symbol-function command))))) @@ -331,30 +323,28 @@ ITEM defines an item as in `easy-menu-define'." (setq keyword (aref item count)) (setq arg (aref item (1+ count))) (setq count (+ 2 count)) - (cond - ((or (eq keyword :included) (eq keyword :visible)) - (setq visible (or arg ''nil))) - ((eq keyword :key-sequence) - (setq cache arg cache-specified t)) - ((eq keyword :keys) (setq keys arg no-name nil)) - ((eq keyword :label) (setq label arg)) - ((eq keyword :active) (setq active (or arg ''nil))) - ((eq keyword :help) (setq prop (cons :help (cons arg prop)))) - ((eq keyword :suffix) (setq suffix arg)) - ((eq keyword :style) (setq style arg)) - ((eq keyword :selected) (setq selected (or arg ''nil))))) + (pcase keyword + ((or `:included `:visible) (setq visible (or arg ''nil))) + (`:key-sequence (setq cache arg cache-specified t)) + (`:keys (setq keys arg no-name nil)) + (`:label (setq label arg)) + ((or `:active `:enable) (setq active (or arg ''nil))) + (`:help (setq prop (cons :help (cons arg prop)))) + (`:suffix (setq suffix arg)) + (`:style (setq style arg)) + (`:selected (setq selected (or arg ''nil))))) (if suffix (setq label (if (stringp suffix) (if (stringp label) (concat label " " suffix) - (list 'concat label (concat " " suffix))) + `(concat ,label ,(concat " " suffix))) (if (stringp label) - (list 'concat (concat label " ") suffix) - (list 'concat label " " suffix))))) + `(concat ,(concat label " ") ,suffix) + `(concat ,label " " ,suffix))))) (cond ((eq style 'button) (setq label (if (stringp label) (concat "[" label "]") - (list 'concat "[" label "]")))) + `(concat "[" ,label "]")))) ((and selected (setq style (assq style easy-menu-button-prefix))) (setq prop (cons :button @@ -674,5 +664,4 @@ In some cases we use that to select between the local and global maps." (provide 'easymenu) -;; arch-tag: 2a04020d-90d2-476d-a7c6-71e072007a4a ;;; easymenu.el ends here diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index e82884206a6..e3888db2a57 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1,8 +1,7 @@ -;;; edebug.el --- a source-level debugger for Emacs Lisp +;;; edebug.el --- a source-level debugger for Emacs Lisp -*- lexical-binding: t -*- -;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1999, -;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 1988-1995, 1997, 1999-2013 Free Software Foundation, +;; Inc. ;; Author: Daniel LaLiberte <liberte@holonexus.org> ;; Maintainer: FSF @@ -53,9 +52,8 @@ ;;; Code: -;;; Bug reporting - -(defalias 'edebug-submit-bug-report 'report-emacs-bug) +(require 'macroexp) +(eval-when-compile (require 'cl-lib)) ;;; Options @@ -193,6 +191,7 @@ Use this with caution since it is not debugged." (defcustom edebug-unwrap-results nil "Non-nil if Edebug should unwrap results of expressions. +That is, Edebug will try to remove its own instrumentation from the result. 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." @@ -234,21 +233,18 @@ If the result is non-nil, then break. Errors are ignored." ;;; Form spec utilities. -(defmacro def-edebug-form-spec (symbol spec-form) - "For compatibility with old version." - (def-edebug-spec symbol (eval spec-form))) -(make-obsolete 'def-edebug-form-spec 'def-edebug-spec "22.1") - (defun get-edebug-spec (symbol) ;; Get the spec of symbol resolving all indirection. - (let ((edebug-form-spec (get symbol 'edebug-form-spec)) - indirect) - (while (and (symbolp edebug-form-spec) - (setq indirect (get edebug-form-spec 'edebug-form-spec))) + (let ((spec nil) + (indirect symbol)) + (while + (progn + (and (symbolp indirect) + (setq indirect + (function-get indirect 'edebug-form-spec 'macro)))) ;; (edebug-trace "indirection: %s" edebug-form-spec) - (setq edebug-form-spec indirect)) - edebug-form-spec - )) + (setq spec indirect)) + spec)) ;;;###autoload (defun edebug-basic-spec (spec) @@ -262,7 +258,7 @@ An extant spec symbol is a symbol that is not a function and has a (setq spec (cdr spec))) t)) ((symbolp spec) - (unless (functionp spec) (get spec 'edebug-form-spec))))) + (unless (functionp spec) (function-get spec 'edebug-form-spec))))) ;;; Utilities @@ -338,9 +334,7 @@ A lambda list keyword is a symbol that starts with `&'." (lambda (e1 e2) (funcall function (car e1) (car e2)))))) -;;(def-edebug-spec edebug-save-restriction t) - -;; Not used. If it is used, def-edebug-spec must be defined before use. +;; Not used. '(defmacro edebug-save-restriction (&rest body) "Evaluate BODY while saving the current buffers restriction. BODY may change buffer outside of current restriction, unlike @@ -348,6 +342,7 @@ save-restriction. BODY may change the current buffer, and the restriction will be restored to the original buffer, and the current buffer remains current. Return the result of the last expression in BODY." + (declare (debug t)) `(let ((edebug:s-r-beg (point-min-marker)) (edebug:s-r-end (point-max-marker))) (unwind-protect @@ -365,6 +360,7 @@ Return the result of the last expression in BODY." ;; Select WINDOW if it is provided and still exists. Otherwise, ;; if buffer is currently shown in several windows, choose one. ;; Otherwise, find a new window, possibly splitting one. + ;; FIXME: We should probably just be using `pop-to-buffer'. (setq window (cond ((and (edebug-window-live-p window) @@ -373,10 +369,10 @@ Return the result of the last expression in BODY." ((eq (window-buffer (selected-window)) buffer) ;; Selected window already displays BUFFER. (selected-window)) - ((edebug-get-buffer-window buffer)) + ((get-buffer-window buffer 0)) ((one-window-p 'nomini) ;; When there's one window only, split it. - (split-window)) + (split-window (minibuffer-selected-window))) ((let ((trace-window (get-buffer-window edebug-trace-buffer))) (catch 'found (dolist (elt (window-list nil 'nomini)) @@ -387,13 +383,10 @@ Return the result of the last expression in BODY." (throw 'found elt)))))) ;; All windows are dedicated or show `edebug-trace-buffer', split ;; selected one. - (t (split-window)))) - (select-window window) + (t (split-window (minibuffer-selected-window))))) (set-window-buffer window buffer) - (set-window-hscroll window 0);; should this be?? - ;; Selecting the window does not set the buffer until command loop. - ;;(set-buffer buffer) - ) + (select-window window) + (set-window-hscroll window 0)) ;; should this be?? (defun edebug-get-displayed-buffer-points () ;; Return a list of buffer point pairs, for all displayed buffers. @@ -446,18 +439,14 @@ Return the result of the last expression in BODY." window-info) (set-window-configuration window-info))) -(defalias 'edebug-get-buffer-window 'get-buffer-window) -(defalias 'edebug-sit-for 'sit-for) -(defalias 'edebug-input-pending-p 'input-pending-p) - - ;;; Redefine read and eval functions ;; read is redefined to maybe instrument forms. ;; eval-defun is redefined to check edebug-all-forms and edebug-all-defs. ;; Save the original read function -(or (fboundp 'edebug-original-read) - (defalias 'edebug-original-read (symbol-function 'read))) +(defalias 'edebug-original-read + (symbol-function (if (fboundp 'edebug-original-read) + 'edebug-original-read 'read))) (defun edebug-read (&optional stream) "Read one Lisp expression as text from STREAM, return as Lisp object. @@ -521,12 +510,14 @@ the minibuffer." ((and (eq (car form) 'defcustom) (default-boundp (nth 1 form))) ;; Force variable to be bound. - (set-default (nth 1 form) (eval (nth 2 form)))) + ;; FIXME: Shouldn't this use the :setter or :initializer? + (set-default (nth 1 form) (eval (nth 2 form) lexical-binding))) ((eq (car form) 'defface) ;; Reset the face. (setq face-new-frame-defaults (assq-delete-all (nth 1 form) face-new-frame-defaults)) (put (nth 1 form) 'face-defface-spec nil) + (put (nth 1 form) 'face-documentation (nth 3 form)) ;; See comments in `eval-defun-1' for purpose of code below (setq form (prog1 `(prog1 ,form (put ',(nth 1 form) 'saved-face @@ -534,7 +525,7 @@ the minibuffer." (put ',(nth 1 form) 'customized-face ,(nth 2 form))) (put (nth 1 form) 'saved-face nil))))) - (setq edebug-result (eval form)) + (setq edebug-result (eval (eval-sexp-add-defvars form) lexical-binding)) (if (not edebugging) (princ edebug-result) edebug-result))) @@ -567,7 +558,8 @@ already is one.)" ;; but this causes problems while edebugging edebug. (let ((edebug-all-forms t) (edebug-all-defs t)) - (edebug-read-top-level-form)))) + (eval-sexp-add-defvars + (edebug-read-top-level-form))))) (defun edebug-read-top-level-form () @@ -619,36 +611,29 @@ already is one.)" ;; The internal data that is needed for edebugging is kept in the ;; buffer-local variable `edebug-form-data'. -(make-variable-buffer-local 'edebug-form-data) - -(defvar edebug-form-data nil) -;; A list of entries associating symbols with buffer regions. -;; This is an automatic buffer local variable. Each entry looks like: -;; @code{(@var{symbol} @var{begin-marker} @var{end-marker}). The markers -;; are at the beginning and end of an entry level form and @var{symbol} is -;; a symbol that holds all edebug related information for the form on its -;; property list. - -;; In the future, the symbol will be irrelevant and edebug data will -;; be stored in the definitions themselves rather than in the property -;; list of a symbol. - -(defun edebug-make-form-data-entry (symbol begin end) - (list symbol begin end)) - -(defsubst edebug-form-data-name (entry) - (car entry)) - -(defsubst edebug-form-data-begin (entry) - (nth 1 entry)) - -(defsubst edebug-form-data-end (entry) - (nth 2 entry)) +(defvar-local edebug-form-data nil + "A list of entries associating symbols with buffer regions. +Each entry is an `edebug--form-data' struct with fields: +SYMBOL, BEGIN-MARKER, and END-MARKER. The markers +are at the beginning and end of an entry level form and SYMBOL is +a symbol that holds all edebug related information for the form on its +property list. + +In the future (haha!), the symbol will be irrelevant and edebug data will +be stored in the definitions themselves rather than in the property +list of a symbol.") + +(cl-defstruct (edebug--form-data + ;; Some callers expect accessors to return nil when passed nil. + (:type list) + (:constructor edebug--make-form-data-entry (name begin end)) + (:predicate nil) (:constructor nil) (:copier nil)) + name begin end) (defsubst edebug-set-form-data-entry (entry name begin end) - (setcar entry name);; in case name is changed - (set-marker (nth 1 entry) begin) - (set-marker (nth 2 entry) end)) + (setf (edebug--form-data-name entry) name) ;; In case name is changed. + (set-marker (edebug--form-data-begin entry) begin) + (set-marker (edebug--form-data-end entry) end)) (defun edebug-get-form-data-entry (pnt &optional end-point) ;; Find the edebug form data entry which is closest to PNT. @@ -656,17 +641,17 @@ already is one.)" ;; Return `nil' if none found. (let ((rest edebug-form-data) closest-entry - (closest-dist 999999)) ;; need maxint here + (closest-dist 999999)) ;; Need maxint here. (while (and rest (< 0 closest-dist)) (let* ((entry (car rest)) - (begin (edebug-form-data-begin entry)) + (begin (edebug--form-data-begin entry)) (dist (- pnt begin))) (setq rest (cdr rest)) (if (and (<= 0 dist) (< dist closest-dist) (or (not end-point) - (= end-point (edebug-form-data-end entry))) - (<= pnt (edebug-form-data-end entry))) + (= end-point (edebug--form-data-end entry))) + (<= pnt (edebug--form-data-end entry))) (setq closest-dist dist closest-entry entry)))) closest-entry)) @@ -675,19 +660,19 @@ already is one.)" ;; and find an entry given a symbol, which should be just assq. (defun edebug-form-data-symbol () -;; Return the edebug data symbol of the form where point is in. -;; If point is not inside a edebuggable form, cause error. - (or (edebug-form-data-name (edebug-get-form-data-entry (point))) + "Return the edebug data symbol of the form where point is in. +If point is not inside a edebuggable form, cause error." + (or (edebug--form-data-name (edebug-get-form-data-entry (point))) (error "Not inside instrumented form"))) (defun edebug-make-top-form-data-entry (new-entry) ;; Make NEW-ENTRY the first element in the `edebug-form-data' list. (edebug-clear-form-data-entry new-entry) - (setq edebug-form-data (cons new-entry edebug-form-data))) + (push new-entry edebug-form-data)) (defun edebug-clear-form-data-entry (entry) -;; If non-nil, clear ENTRY out of the form data. -;; Maybe clear the markers and delete the symbol's edebug property? + "If non-nil, clear ENTRY out of the form data. +Maybe clear the markers and delete the symbol's edebug property?" (if entry (progn ;; Instead of this, we could just find all contained forms. @@ -885,17 +870,12 @@ already is one.)" (edebug-storing-offsets (1- (point)) 'quote) (edebug-read-storing-offsets stream))) -(defvar edebug-read-backquote-level 0 - "If non-zero, we're in a new-style backquote. -It should never be negative. This controls how we read comma constructs.") - (defun edebug-read-backquote (stream) ;; Turn `thing into (\` thing) (forward-char 1) (list (edebug-storing-offsets (1- (point)) '\`) - (let ((edebug-read-backquote-level (1+ edebug-read-backquote-level))) - (edebug-read-storing-offsets stream)))) + (edebug-read-storing-offsets stream))) (defun edebug-read-comma (stream) ;; Turn ,thing into (\, thing). Handle ,@ and ,. also. @@ -910,12 +890,9 @@ It should never be negative. This controls how we read comma constructs.") (forward-char 1))) ;; Generate the same structure of offsets we would have ;; if the resulting list appeared verbatim in the input text. - (if (zerop edebug-read-backquote-level) - (edebug-storing-offsets opoint symbol) - (list - (edebug-storing-offsets opoint symbol) - (let ((edebug-read-backquote-level (1- edebug-read-backquote-level))) - (edebug-read-storing-offsets stream))))))) + (list + (edebug-storing-offsets opoint symbol) + (edebug-read-storing-offsets stream))))) (defun edebug-read-function (stream) ;; Turn #'thing into (function thing) @@ -923,8 +900,7 @@ It should never be negative. This controls how we read comma constructs.") (cond ((eq ?\' (following-char)) (forward-char 1) (list - (edebug-storing-offsets (- (point) 2) - (if (featurep 'cl) 'function* 'function)) + (edebug-storing-offsets (- (point) 2) 'function) (edebug-read-storing-offsets stream))) ((memq (following-char) '(?: ?B ?O ?X ?b ?o ?x ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?0)) @@ -937,17 +913,7 @@ It should never be negative. This controls how we read comma constructs.") (prog1 (let ((elements)) (while (not (memq (edebug-next-token-class) '(rparen dot))) - (if (and (eq (edebug-next-token-class) 'backquote) - (null elements) - (zerop edebug-read-backquote-level)) - (progn - ;; Old style backquote. - (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. - (push (edebug-storing-offsets (1- (point)) '\`) elements)) - (push (edebug-read-storing-offsets stream) elements))) + (push (edebug-read-storing-offsets stream) elements)) (setq elements (nreverse elements)) (if (eq 'dot (edebug-next-token-class)) (let (dotted-form) @@ -1098,7 +1064,8 @@ It should never be negative. This controls how we read comma constructs.") ;; If it gets an error, make it nil. (let ((temp-hook edebug-setup-hook)) (setq edebug-setup-hook nil) - (run-hooks 'temp-hook)) + (if (functionp temp-hook) (funcall temp-hook) + (mapc #'funcall temp-hook))) (let (result edebug-top-window-data @@ -1235,8 +1202,8 @@ It should never be negative. This controls how we read comma constructs.") (defvar edebug-offset-list) ; the list of offset positions. (defun edebug-inc-offset (offset) - ;; modifies edebug-offset-index and edebug-offset-list - ;; accesses edebug-func-marc and buffer point + ;; Modifies edebug-offset-index and edebug-offset-list + ;; accesses edebug-func-marc and buffer point. (prog1 edebug-offset-index (setq edebug-offset-list (cons (- offset edebug-form-begin-marker) @@ -1249,13 +1216,11 @@ It should never be negative. This controls how we read comma constructs.") ;; given FORM. Looks like: ;; (edebug-after (edebug-before BEFORE-INDEX) AFTER-INDEX FORM) ;; Also increment the offset index for subsequent use. - (list 'edebug-after - (list 'edebug-before before-index) - after-index form)) + `(edebug-after (edebug-before ,before-index) ,after-index ,form)) (defun edebug-make-after-form (form after-index) ;; Like edebug-make-before-and-after-form, but only after. - (list 'edebug-after 0 after-index form)) + `(edebug-after 0 ,after-index ,form)) (defun edebug-unwrap (sexp) @@ -1267,10 +1232,7 @@ expressions; a `progn' form will be returned enclosing these forms." ((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)))) + (macroexp-progn (nthcdr 2 (nth 1 (nth 3 sexp))))) (t sexp);; otherwise it is not wrapped, so just return it. ) sexp)) @@ -1303,12 +1265,12 @@ expressions; a `progn' form will be returned enclosing these forms." ;; 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. + ;; This is a hack, but I haven't 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) + (edebug--form-data-begin form-data-entry) ;; Buffer must be current-buffer for this to work: (set-marker (make-marker) form-begin)))) @@ -1318,7 +1280,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; For definitions. ;; (edebug-containing-def-name edebug-def-name) ;; Get name from form-data, if any. - (edebug-old-def-name (edebug-form-data-name form-data-entry)) + (edebug-old-def-name (edebug--form-data-name form-data-entry)) edebug-def-name edebug-def-args edebug-def-interactive @@ -1348,7 +1310,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; In the latter case, pointers to the entry remain eq. (if (not form-data-entry) (setq form-data-entry - (edebug-make-form-data-entry + (edebug--make-form-data-entry edebug-def-name edebug-form-begin-marker ;; Buffer must be current-buffer. @@ -1534,18 +1496,18 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Otherwise it signals an error. The place of the error is found ;; with the two before- and after-offset functions. -(defun edebug-no-match (cursor &rest edebug-args) +(defun edebug-no-match (cursor &rest args) ;; Throw a no-match, or signal an error immediately if gate is active. ;; Remember this point in case we need to report this error. (setq edebug-error-point (or edebug-error-point (edebug-before-offset cursor)) - edebug-best-error (or edebug-best-error edebug-args)) + edebug-best-error (or edebug-best-error args)) (if (and edebug-gate (not edebug-&optional)) (progn (if edebug-error-point (goto-char edebug-error-point)) - (apply 'edebug-syntax-error edebug-args)) - (funcall 'throw 'no-match edebug-args))) + (apply 'edebug-syntax-error args)) + (throw 'no-match args))) (defun edebug-match (cursor specs) @@ -1575,7 +1537,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; 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?") + (error "Too deep - perhaps infinite loop in spec?") (1+ edebug-matching-depth)))) (cond ((null specs) nil) @@ -1772,7 +1734,7 @@ expressions; a `progn' form will be returned enclosing these forms." specs)))) -(defun edebug-match-gate (cursor) +(defun edebug-match-gate (_cursor) ;; Simply set the gate to prevent backtracking at this level. (setq edebug-gate t) nil) @@ -1861,7 +1823,7 @@ expressions; a `progn' form will be returned enclosing these forms." nil)) -(defun edebug-match-function (cursor) +(defun edebug-match-function (_cursor) (error "Use function-form instead of function in edebug spec")) (defun edebug-match-&define (cursor specs) @@ -1918,7 +1880,7 @@ expressions; a `progn' form will be returned enclosing these forms." (edebug-move-cursor cursor) (list name))) -(defun edebug-match-colon-name (cursor spec) +(defun edebug-match-colon-name (_cursor spec) ;; Set the edebug-def-name to the spec. (setq edebug-def-name (if edebug-def-name @@ -1955,7 +1917,6 @@ expressions; a `progn' form will be returned enclosing these forms." ;;;; Edebug Form Specs ;;; ========================================================== -;;; See cl-specs.el for common lisp specs. ;;;;* Spec for def-edebug-spec ;;; Out of date. @@ -2004,6 +1965,8 @@ expressions; a `progn' form will be returned enclosing these forms." def-body)) ;; FIXME? Isn't this missing the doc-string? Cf defun. (def-edebug-spec defmacro + ;; FIXME: Improve `declare' so we can Edebug gv-expander and + ;; gv-setter declarations. (&define name lambda-list [&optional ("declare" &rest sexp)] def-body)) (def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list. @@ -2028,25 +1991,17 @@ expressions; a `progn' form will be returned enclosing these forms." ;; 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)) -;; FIXME? The manual has a gate here. +;; FIXME? The manual uses this form (maybe that's just for illustration?): +;; (def-edebug-spec let +;; ((&rest &or symbolp (gate symbolp &optional form)) +;; body)) (def-edebug-spec let ((&rest &or (symbolp &optional form) symbolp) body)) @@ -2107,51 +2062,12 @@ expressions; a `progn' form will be returned enclosing these forms." &or ("quote" edebug-\`) def-form)) ;; New byte compiler. -(def-edebug-spec defsubst defun) -(def-edebug-spec dont-compile t) -(def-edebug-spec eval-when-compile t) -(def-edebug-spec eval-and-compile t) (def-edebug-spec save-selected-window t) (def-edebug-spec save-current-buffer t) -(def-edebug-spec delay-mode-hooks t) -(def-edebug-spec with-temp-file t) -(def-edebug-spec with-temp-message t) -(def-edebug-spec with-syntax-table t) -(def-edebug-spec push (form sexp)) -(def-edebug-spec pop (sexp)) - -(def-edebug-spec 1value (form)) -(def-edebug-spec noreturn (form)) - ;; Anything else? - -;; Some miscellaneous specs for macros in public packages. -;; Send me yours. - -;; advice.el by Hans Chalupsky (hans@cs.buffalo.edu) - -(def-edebug-spec ad-dolist ((symbolp form &optional form) body)) -(def-edebug-spec defadvice - (&define name ;; thing being advised. - (name ;; class is [&or "before" "around" "after" - ;; "activation" "deactivation"] - name ;; name of advice - &rest sexp ;; optional position and flags - ) - [&optional stringp] - [&optional ("interactive" interactive)] - def-body)) - -(def-edebug-spec easy-menu-define (symbolp body)) - -(def-edebug-spec with-custom-print body) - -(def-edebug-spec sregexq (&rest sexp)) -(def-edebug-spec rx (&rest sexp)) - ;;; The debugger itself (defvar edebug-active nil) ;; Non-nil when edebug is active @@ -2188,10 +2104,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Dynamically bound variables, declared globally but left unbound. (defvar edebug-function) ; the function being executed. change name!! -(defvar edebug-args) ; the arguments of the function (defvar edebug-data) ; the edebug data for the function -(defvar edebug-value) ; the result of the expression -(defvar edebug-after-index) (defvar edebug-def-mark) ; the mark for the definition (defvar edebug-freq-count) ; the count of expression visits. (defvar edebug-coverage) ; the coverage results of each expression of function. @@ -2207,8 +2120,6 @@ expressions; a `progn' form will be returned enclosing these forms." (defvar edebug-outside-debug-on-error) ; the value of debug-on-error outside (defvar edebug-outside-debug-on-quit) ; the value of debug-on-quit outside -(defvar edebug-outside-overriding-local-map) -(defvar edebug-outside-overriding-terminal-local-map) (defvar edebug-outside-pre-command-hook) (defvar edebug-outside-post-command-hook) @@ -2217,7 +2128,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;;; Handling signals -(defun edebug-signal (edebug-signal-name edebug-signal-data) +(defun edebug-signal (signal-name signal-data) "Signal an error. Args are SIGNAL-NAME, and associated DATA. A signal name is a symbol with an `error-conditions' property that is a list of condition names. @@ -2231,19 +2142,18 @@ See `condition-case'. This is the Edebug replacement for the standard `signal'. It should only be active while Edebug is. It checks `debug-on-error' to see whether it should call the debugger. When execution is resumed, the -error is signaled again. -\n(fn SIGNAL-NAME DATA)" - (if (and (listp debug-on-error) (memq edebug-signal-name debug-on-error)) - (edebug 'error (cons edebug-signal-name edebug-signal-data))) +error is signaled again." + (if (and (listp debug-on-error) (memq signal-name debug-on-error)) + (edebug 'error (cons signal-name signal-data))) ;; If we reach here without another non-local exit, then send signal again. ;; i.e. the signal is not continuable, yet. ;; Avoid infinite recursion. (let ((signal-hook-function nil)) - (signal edebug-signal-name edebug-signal-data))) + (signal signal-name signal-data))) ;;; Entering Edebug -(defun edebug-enter (edebug-function edebug-args edebug-body) +(defun edebug-enter (function args body) ;; Entering FUNC. The arguments are ARGS, and the body is BODY. ;; Setup edebug variables and evaluate BODY. This function is called ;; when a function evaluated with edebug-eval-top-level-form is entered. @@ -2252,83 +2162,51 @@ error is signaled again. ;; Is this the first time we are entering edebug since ;; lower-level recursive-edit command? ;; More precisely, this tests whether Edebug is currently active. - (if (not edebug-entered) - (let ((edebug-entered t) - ;; Binding max-lisp-eval-depth here is OK, - ;; but not inside an unwind-protect. - ;; Doing it here also keeps it from growing too large. - (max-lisp-eval-depth (+ 100 max-lisp-eval-depth)) ; too much?? - (max-specpdl-size (+ 200 max-specpdl-size)) - - (debugger edebug-debugger) ; only while edebug is active. - (edebug-outside-debug-on-error debug-on-error) - (edebug-outside-debug-on-quit debug-on-quit) - ;; Binding these may not be the right thing to do. - ;; We want to allow the global values to be changed. - (debug-on-error (or debug-on-error edebug-on-error)) - (debug-on-quit edebug-on-quit) - - ;; Lexical bindings must be uncompiled for this to work. - (cl-lexical-debug t) - - (edebug-outside-overriding-local-map overriding-local-map) - (edebug-outside-overriding-terminal-local-map - overriding-terminal-local-map) - - ;; Save the outside value of executing macro. (here??) - (edebug-outside-executing-macro executing-kbd-macro) - (edebug-outside-pre-command-hook - (edebug-var-status 'pre-command-hook)) - (edebug-outside-post-command-hook - (edebug-var-status 'post-command-hook))) - (unwind-protect - (let (;; Don't keep reading from an executing kbd macro - ;; within edebug unless edebug-continue-kbd-macro is - ;; non-nil. Again, local binding may not be best. - (executing-kbd-macro - (if edebug-continue-kbd-macro executing-kbd-macro)) - - ;; Don't get confused by the user's keymap changes. - (overriding-local-map nil) - (overriding-terminal-local-map nil) - - (signal-hook-function 'edebug-signal) - - ;; Disable command hooks. This is essential when - ;; a hook function is instrumented - to avoid infinite loop. - ;; This may be more than we need, however. - (pre-command-hook nil) - (post-command-hook nil)) - (setq edebug-execution-mode (or edebug-next-execution-mode - edebug-initial-mode - edebug-execution-mode) - edebug-next-execution-mode nil) - (edebug-enter edebug-function edebug-args edebug-body)) - ;; Reset global variables in case outside value was changed. - (setq executing-kbd-macro edebug-outside-executing-macro) - (edebug-restore-status - 'post-command-hook edebug-outside-post-command-hook) - (edebug-restore-status - 'pre-command-hook edebug-outside-pre-command-hook))) - - (let* ((edebug-data (get edebug-function 'edebug)) - (edebug-def-mark (car edebug-data)) ; mark at def start - (edebug-freq-count (get edebug-function 'edebug-freq-count)) - (edebug-coverage (get edebug-function 'edebug-coverage)) - (edebug-buffer (marker-buffer edebug-def-mark)) - - (edebug-stack (cons edebug-function edebug-stack)) - (edebug-offset-indices (cons 0 edebug-offset-indices)) - ) - (if (get edebug-function 'edebug-on-entry) - (progn - (setq edebug-execution-mode 'step) - (if (eq (get edebug-function 'edebug-on-entry) 'temp) - (put edebug-function 'edebug-on-entry nil)))) - (if edebug-trace - (edebug-enter-trace edebug-body) - (funcall edebug-body)) - ))) + (let ((edebug-function function)) + (if (not edebug-entered) + (let ((edebug-entered t) + ;; Binding max-lisp-eval-depth here is OK, + ;; but not inside an unwind-protect. + ;; Doing it here also keeps it from growing too large. + (max-lisp-eval-depth (+ 100 max-lisp-eval-depth)) ; too much?? + (max-specpdl-size (+ 200 max-specpdl-size)) + + (debugger edebug-debugger) ; only while edebug is active. + (edebug-outside-debug-on-error debug-on-error) + (edebug-outside-debug-on-quit debug-on-quit) + ;; Binding these may not be the right thing to do. + ;; We want to allow the global values to be changed. + (debug-on-error (or debug-on-error edebug-on-error)) + (debug-on-quit edebug-on-quit) + + ;; Lexical bindings must be uncompiled for this to work. + (cl-lexical-debug t)) + (unwind-protect + (let ((signal-hook-function 'edebug-signal)) + (setq edebug-execution-mode (or edebug-next-execution-mode + edebug-initial-mode + edebug-execution-mode) + edebug-next-execution-mode nil) + (edebug-enter function args body)))) + + (let* ((edebug-data (get function 'edebug)) + (edebug-def-mark (car edebug-data)) ; mark at def start + (edebug-freq-count (get function 'edebug-freq-count)) + (edebug-coverage (get function 'edebug-coverage)) + (edebug-buffer (marker-buffer edebug-def-mark)) + + (edebug-stack (cons function edebug-stack)) + (edebug-offset-indices (cons 0 edebug-offset-indices)) + ) + (if (get function 'edebug-on-entry) + (progn + (setq edebug-execution-mode 'step) + (if (eq (get function 'edebug-on-entry) 'temp) + (put function 'edebug-on-entry nil)))) + (if edebug-trace + (edebug--enter-trace function args body) + (funcall body)) + )))) (defun edebug-var-status (var) "Return a cons cell describing the status of VAR's current binding. @@ -2355,14 +2233,14 @@ STATUS should be a list returned by `edebug-var-status'." (t (set var value))))) -(defun edebug-enter-trace (edebug-body) +(defun edebug--enter-trace (function args body) (let ((edebug-stack-depth (1+ edebug-stack-depth)) edebug-result) (edebug-print-trace-before - (format "%s args: %s" edebug-function edebug-args)) - (prog1 (setq edebug-result (funcall edebug-body)) + (format "%s args: %s" function args)) + (prog1 (setq edebug-result (funcall body)) (edebug-print-trace-after - (format "%s result: %s" edebug-function edebug-result))))) + (format "%s result: %s" function edebug-result))))) (def-edebug-spec edebug-tracing (form body)) @@ -2390,49 +2268,49 @@ MSG is printed after `::::} '." -(defun edebug-slow-before (edebug-before-index) +(defun edebug-slow-before (before-index) (unless edebug-active ;; Debug current function given BEFORE position. ;; Called from functions compiled with edebug-eval-top-level-form. ;; Return the before index. - (setcar edebug-offset-indices edebug-before-index) + (setcar edebug-offset-indices before-index) ;; Increment frequency count - (aset edebug-freq-count edebug-before-index - (1+ (aref edebug-freq-count edebug-before-index))) + (aset edebug-freq-count before-index + (1+ (aref edebug-freq-count before-index))) (if (or (not (memq edebug-execution-mode '(Go-nonstop next))) - (edebug-input-pending-p)) - (edebug-debugger edebug-before-index 'before nil))) - edebug-before-index) + (input-pending-p)) + (edebug-debugger before-index 'before nil))) + before-index) -(defun edebug-fast-before (edebug-before-index) +(defun edebug-fast-before (_before-index) ;; Do nothing. ) -(defun edebug-slow-after (edebug-before-index edebug-after-index edebug-value) +(defun edebug-slow-after (_before-index after-index value) (if edebug-active - edebug-value + value ;; Debug current function given AFTER position and VALUE. ;; Called from functions compiled with edebug-eval-top-level-form. ;; Return VALUE. - (setcar edebug-offset-indices edebug-after-index) + (setcar edebug-offset-indices after-index) ;; Increment frequency count - (aset edebug-freq-count edebug-after-index - (1+ (aref edebug-freq-count edebug-after-index))) - (if edebug-test-coverage (edebug-update-coverage)) + (aset edebug-freq-count after-index + (1+ (aref edebug-freq-count after-index))) + (if edebug-test-coverage (edebug--update-coverage after-index value)) (if (and (eq edebug-execution-mode 'Go-nonstop) - (not (edebug-input-pending-p))) + (not (input-pending-p))) ;; Just return result. - edebug-value - (edebug-debugger edebug-after-index 'after edebug-value) + value + (edebug-debugger after-index 'after value) ))) -(defun edebug-fast-after (edebug-before-index edebug-after-index edebug-value) +(defun edebug-fast-after (_before-index _after-index value) ;; Do nothing but return the value. - edebug-value) + value) (defun edebug-run-slow () (defalias 'edebug-before 'edebug-slow-before) @@ -2446,19 +2324,18 @@ MSG is printed after `::::} '." (edebug-run-slow) -(defun edebug-update-coverage () - (let ((old-result (aref edebug-coverage edebug-after-index))) +(defun edebug--update-coverage (after-index value) + (let ((old-result (aref edebug-coverage after-index))) (cond ((eq 'ok-coverage old-result)) ((eq 'unknown old-result) - (aset edebug-coverage edebug-after-index edebug-value)) + (aset edebug-coverage after-index value)) ;; Test if a different result. - ((not (eq edebug-value old-result)) - (aset edebug-coverage edebug-after-index 'ok-coverage))))) + ((not (eq value old-result)) + (aset edebug-coverage after-index 'ok-coverage))))) ;; Dynamically declared unbound variables. -(defvar edebug-arg-mode) ; the mode, either before, after, or error (defvar edebug-breakpoints) (defvar edebug-break-data) ; break data for current function. (defvar edebug-break) ; whether a break occurred. @@ -2469,32 +2346,34 @@ MSG is printed after `::::} '." (defvar edebug-global-break-result nil) -(defun edebug-debugger (edebug-offset-index edebug-arg-mode edebug-value) +(defun edebug-debugger (offset-index arg-mode value) (if inhibit-redisplay ;; Don't really try to enter edebug within an eval from redisplay. - edebug-value + value ;; Check breakpoints and pending input. - ;; If edebug display should be updated, call edebug-display. - ;; Return edebug-value. + ;; If edebug display should be updated, call edebug--display. + ;; Return value. (let* ( ;; This needs to be here since breakpoints may be changed. (edebug-breakpoints (car (cdr edebug-data))) ; list of breakpoints - (edebug-break-data (assq edebug-offset-index edebug-breakpoints)) + (edebug-break-data (assq offset-index edebug-breakpoints)) (edebug-break-condition (car (cdr edebug-break-data))) (edebug-global-break (if edebug-global-break-condition (condition-case nil (setq edebug-global-break-result + ;; FIXME: lexbind. (eval edebug-global-break-condition)) (error nil)))) (edebug-break)) -;;; (edebug-trace "exp: %s" edebug-value) + ;;(edebug-trace "exp: %s" value) ;; Test whether we should break. (setq edebug-break (or edebug-global-break (and edebug-break-data (or (not edebug-break-condition) (setq edebug-break-result + ;; FIXME: lexbind. (eval edebug-break-condition)))))) (if (and edebug-break (nth 2 edebug-break-data)) ; is it temporary? @@ -2507,11 +2386,10 @@ MSG is printed after `::::} '." ;; or break, or input is pending, (if (or (not (memq edebug-execution-mode '(go continue Continue-fast))) edebug-break - (edebug-input-pending-p)) - (edebug-display)) ; <--------------- display + (input-pending-p)) + (edebug--display value offset-index arg-mode)) ; <---------- display - edebug-value - ))) + value))) ;; window-start now stored with each function. @@ -2543,8 +2421,9 @@ MSG is printed after `::::} '." ;; Emacs 19 adds an arg to mark and mark-marker. (defalias 'edebug-mark-marker 'mark-marker) +(defvar edebug-outside-unread-command-events) -(defun edebug-display () +(defun edebug--display (value offset-index arg-mode) (unless (marker-position edebug-def-mark) ;; The buffer holding the source has been killed. ;; Let's at least show a backtrace so the user can figure out @@ -2553,11 +2432,11 @@ MSG is printed after `::::} '." ;; Setup windows for edebug, determine mode, maybe enter recursive-edit. ;; Uses local variables of edebug-enter, edebug-before, edebug-after ;; and edebug-debugger. - (let ((edebug-active t) ; for minor mode alist + (let ((edebug-active t) ; For minor mode alist. (edebug-with-timeout-suspend (with-timeout-suspend)) - edebug-stop ; should we enter recursive-edit + edebug-stop ; Should we enter recursive-edit? (edebug-point (+ edebug-def-mark - (aref (nth 2 edebug-data) edebug-offset-index))) + (aref (nth 2 edebug-data) offset-index))) edebug-buffer-outside-point ; current point in edebug-buffer ;; window displaying edebug-buffer (edebug-window-data (nth 3 edebug-data)) @@ -2566,12 +2445,12 @@ MSG is printed after `::::} '." (edebug-outside-point (point)) (edebug-outside-mark (edebug-mark)) (edebug-outside-unread-command-events unread-command-events) - edebug-outside-windows ; window or screen configuration + edebug-outside-windows ; Window or screen configuration. edebug-buffer-points - edebug-eval-buffer ; declared here so we can kill it below - (edebug-eval-result-list (and edebug-eval-list - (edebug-eval-result-list))) + edebug-eval-buffer ; Declared here so we can kill it below. + (eval-result-list (and edebug-eval-list + (edebug-eval-result-list))) edebug-trace-window edebug-trace-window-start @@ -2584,7 +2463,7 @@ MSG is printed after `::::} '." (let ((overlay-arrow-position overlay-arrow-position) (overlay-arrow-string overlay-arrow-string) (cursor-in-echo-area nil) - (unread-command-events unread-command-events) + (unread-command-events nil) ;; any others?? ) (setq-default cursor-in-non-selected-windows t) @@ -2592,9 +2471,9 @@ MSG is printed after `::::} '." (let ((debug-on-error nil)) (error "Buffer defining %s not found" edebug-function))) - (if (eq 'after edebug-arg-mode) + (if (eq 'after arg-mode) ;; Compute result string now before windows are modified. - (edebug-compute-previous-result edebug-value)) + (edebug-compute-previous-result value)) (if edebug-save-windows ;; Save windows now before we modify them. @@ -2618,7 +2497,7 @@ MSG is printed after `::::} '." ;; Now display eval list, if any. ;; This is done after the pop to edebug-buffer ;; so that buffer-window correspondence is correct after quitting. - (edebug-eval-display edebug-eval-result-list) + (edebug-eval-display eval-result-list) ;; The evaluation list better not have deleted edebug-window-data. (select-window (car edebug-window-data)) (set-buffer edebug-buffer) @@ -2626,7 +2505,7 @@ MSG is printed after `::::} '." (setq edebug-buffer-outside-point (point)) (goto-char edebug-point) - (if (eq 'before edebug-arg-mode) + (if (eq 'before arg-mode) ;; Check whether positions are up-to-date. ;; This assumes point is never before symbol. (if (not (memq (following-char) '(?\( ?\# ?\` ))) @@ -2639,7 +2518,7 @@ MSG is printed after `::::} '." (edebug-adjust-window (cdr edebug-window-data))) ;; Test if there is input, not including keyboard macros. - (if (edebug-input-pending-p) + (if (input-pending-p) (progn (setq edebug-execution-mode 'step edebug-stop t) @@ -2650,14 +2529,14 @@ MSG is printed after `::::} '." (edebug-overlay-arrow) (cond - ((eq 'error edebug-arg-mode) + ((eq 'error arg-mode) ;; Display error message (setq edebug-execution-mode 'step) (edebug-overlay-arrow) (beep) - (if (eq 'quit (car edebug-value)) + (if (eq 'quit (car value)) (message "Quit") - (edebug-report-error edebug-value))) + (edebug-report-error value))) (edebug-break (cond (edebug-global-break @@ -2674,41 +2553,40 @@ MSG is printed after `::::} '." (t (message ""))) - (setq unread-command-events nil) - (if (eq 'after edebug-arg-mode) + (if (eq 'after arg-mode) (progn ;; Display result of previous evaluation. (if (and edebug-break (not (eq edebug-execution-mode 'Continue-fast))) - (edebug-sit-for edebug-sit-for-seconds)) ; Show message. + (sit-for edebug-sit-for-seconds)) ; Show message. (edebug-previous-result))) (cond (edebug-break (cond ((eq edebug-execution-mode 'continue) - (edebug-sit-for edebug-sit-for-seconds)) - ((eq edebug-execution-mode 'Continue-fast) (edebug-sit-for 0)) + (sit-for edebug-sit-for-seconds)) + ((eq edebug-execution-mode 'Continue-fast) (sit-for 0)) (t (setq edebug-stop t)))) ;; not edebug-break ((eq edebug-execution-mode 'trace) - (edebug-sit-for edebug-sit-for-seconds)) ; Force update and pause. + (sit-for edebug-sit-for-seconds)) ; Force update and pause. ((eq edebug-execution-mode 'Trace-fast) - (edebug-sit-for 0))) ; Force update and continue. + (sit-for 0))) ; Force update and continue. (unwind-protect (if (or edebug-stop (memq edebug-execution-mode '(step next)) - (eq edebug-arg-mode 'error)) + (eq arg-mode 'error)) (progn ;; (setq edebug-execution-mode 'step) ;; (edebug-overlay-arrow) ; This doesn't always show up. - (edebug-recursive-edit))) ; <---------- Recursive edit + (edebug--recursive-edit arg-mode))) ; <----- Recursive edit ;; Reset the edebug-window-data to whatever it is now. (let ((window (if (eq (window-buffer) edebug-buffer) (selected-window) - (edebug-get-buffer-window edebug-buffer)))) + (get-buffer-window edebug-buffer)))) ;; Remember window-start for edebug-buffer, if still displayed. (if window (progn @@ -2786,6 +2664,8 @@ MSG is printed after `::::} '." (goto-char edebug-buffer-outside-point)) ;; ... nothing more. ) + ;; Could be an option to keep eval display up. + (if edebug-eval-buffer (kill-buffer edebug-eval-buffer)) (with-timeout-unsuspend edebug-with-timeout-suspend) ;; Reset global variables to outside values in case they were changed. (setq @@ -2823,26 +2703,15 @@ MSG is printed after `::::} '." ;; in versions where the variable is *not* built-in. ;; Emacs 18 FIXME -(defvar edebug-outside-unread-command-char) ;; Emacs 19. (defvar edebug-outside-last-command-event) -(defvar edebug-outside-unread-command-events) (defvar edebug-outside-last-input-event) (defvar edebug-outside-last-event-frame) (defvar edebug-outside-last-nonmenu-event) (defvar edebug-outside-track-mouse) -;; Disable byte compiler warnings about unread-command-char and -event -;; (maybe works with byte-compile-version 2.22 at least) -(defvar edebug-unread-command-char-warning) -(defvar edebug-unread-command-event-warning) -(eval-when-compile ; FIXME - (setq edebug-unread-command-char-warning - (get 'unread-command-char 'byte-obsolete-variable)) - (put 'unread-command-char 'byte-obsolete-variable nil)) - -(defun edebug-recursive-edit () +(defun edebug--recursive-edit (arg-mode) ;; Start up a recursive edit inside of edebug. ;; The current buffer is the edebug-buffer, which is put into edebug-mode. ;; Assume that none of the variables below are buffer-local. @@ -2863,14 +2732,20 @@ MSG is printed after `::::} '." (edebug-outside-map (current-local-map)) - (edebug-outside-standard-output standard-output) + ;; Save the outside value of executing macro. (here??) + (edebug-outside-executing-macro executing-kbd-macro) + (edebug-outside-pre-command-hook + (edebug-var-status 'pre-command-hook)) + (edebug-outside-post-command-hook + (edebug-var-status 'post-command-hook)) + + (edebug-outside-standard-output standard-output) (edebug-outside-standard-input standard-input) (edebug-outside-defining-kbd-macro defining-kbd-macro) (edebug-outside-last-command last-command) (edebug-outside-this-command this-command) - (edebug-outside-unread-command-char unread-command-char) ; FIXME (edebug-outside-current-prefix-arg current-prefix-arg) (edebug-outside-last-input-event last-input-event) @@ -2886,9 +2761,6 @@ MSG is printed after `::::} '." ;; We could set these to the values for previous edebug call. (last-command last-command) (this-command this-command) - - ;; Assume no edebug command sets unread-command-char. - (unread-command-char -1) (current-prefix-arg nil) ;; More for Emacs 19 @@ -2898,7 +2770,20 @@ MSG is printed after `::::} '." (last-nonmenu-event nil) (track-mouse nil) - ;; Bind again to outside values. + (standard-output t) + (standard-input t) + + ;; Don't keep reading from an executing kbd macro + ;; within edebug unless edebug-continue-kbd-macro is + ;; non-nil. Again, local binding may not be best. + (executing-kbd-macro + (if edebug-continue-kbd-macro executing-kbd-macro)) + + ;; Don't get confused by the user's keymap changes. + (overriding-local-map nil) + (overriding-terminal-local-map nil) + + ;; Bind again to outside values. (debug-on-error edebug-outside-debug-on-error) (debug-on-quit edebug-outside-debug-on-quit) @@ -2906,11 +2791,17 @@ MSG is printed after `::::} '." (defining-kbd-macro (if edebug-continue-kbd-macro defining-kbd-macro)) + ;; Disable command hooks. This is essential when + ;; a hook function is instrumented - to avoid infinite loop. + ;; This may be more than we need, however. + (pre-command-hook nil) + (post-command-hook nil) + ;; others?? ) (if (and (eq edebug-execution-mode 'go) - (not (memq edebug-arg-mode '(after error)))) + (not (memq arg-mode '(after error)))) (message "Break")) (setq buffer-read-only t) @@ -2924,8 +2815,6 @@ MSG is printed after `::::} '." (setq signal-hook-function 'edebug-signal) (if edebug-backtrace-buffer (kill-buffer edebug-backtrace-buffer)) - ;; Could be an option to keep eval display up. - (if edebug-eval-buffer (kill-buffer edebug-eval-buffer)) ;; Remember selected-window after recursive-edit. ;; (setq edebug-inside-window (selected-window)) @@ -2952,7 +2841,6 @@ MSG is printed after `::::} '." last-command-event edebug-outside-last-command-event last-command edebug-outside-last-command this-command edebug-outside-this-command - unread-command-char edebug-outside-unread-command-char current-prefix-arg edebug-outside-current-prefix-arg last-input-event edebug-outside-last-input-event last-event-frame edebug-outside-last-event-frame @@ -2961,17 +2849,21 @@ MSG is printed after `::::} '." standard-output edebug-outside-standard-output standard-input edebug-outside-standard-input - defining-kbd-macro edebug-outside-defining-kbd-macro - )) - )) + defining-kbd-macro edebug-outside-defining-kbd-macro) + + (setq executing-kbd-macro edebug-outside-executing-macro) + (edebug-restore-status + 'post-command-hook edebug-outside-post-command-hook) + (edebug-restore-status + 'pre-command-hook edebug-outside-pre-command-hook)))) ;;; Display related functions (defun edebug-adjust-window (old-start) ;; If pos is not visible, adjust current window to fit following context. -;;; (message "window: %s old-start: %s window-start: %s pos: %s" -;;; (selected-window) old-start (window-start) (point)) (sit-for 5) + ;; (message "window: %s old-start: %s window-start: %s pos: %s" + ;; (selected-window) old-start (window-start) (point)) (sit-for 5) (if (not (pos-visible-in-window-p)) (progn ;; First try old-start @@ -2979,7 +2871,7 @@ MSG is printed after `::::} '." (set-window-start (selected-window) old-start)) (if (not (pos-visible-in-window-p)) (progn -;; (message "resetting window start") (sit-for 2) + ;; (message "resetting window start") (sit-for 2) (set-window-start (selected-window) (save-excursion @@ -3009,7 +2901,7 @@ MSG is printed after `::::} '." ;; 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)))) + (let ((pos (line-beginning-position))) (setq overlay-arrow-string (cdr (assq edebug-execution-mode edebug-arrow-alist))) (setq overlay-arrow-position (make-marker)) @@ -3076,7 +2968,6 @@ Otherwise, toggle for all windows." (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) @@ -3119,12 +3010,12 @@ before returning. The default is one second." (current-buffer) (point) (if (marker-buffer (edebug-mark-marker)) (marker-position (edebug-mark-marker)) "<not set>")) - (edebug-sit-for arg) + (sit-for arg) (edebug-pop-to-buffer edebug-buffer (car edebug-window-data))))) ;; Joe Wells, here is a start at your idea of adding a buffer to the internal -;; display list. Still need to use this list in edebug-display. +;; display list. Still need to use this list in edebug--display. '(defvar edebug-display-buffer-list nil "List of buffers that edebug will display when it is active.") @@ -3219,7 +3110,7 @@ before returning. The default is one second." "Modify the breakpoint for the form at point or after it. Set it if FLAG is non-nil, clear it otherwise. Then move to that point. If CONDITION or TEMPORARY are non-nil, add those attributes to -the breakpoint. " +the breakpoint." (let ((edebug-stop-point (edebug-find-stop-point))) (if edebug-stop-point (let* ((edebug-def-name (car edebug-stop-point)) @@ -3416,7 +3307,7 @@ go to the end of the last sexp, or if that is the same point, then step." ;; Return the function symbol, or nil if not instrumented. (let ((func-marker (get func 'edebug))) (cond - ((markerp func-marker) + ((and (markerp func-marker) (marker-buffer func-marker)) ;; It is uninstrumented, so instrument it. (with-current-buffer (marker-buffer func-marker) (goto-char func-marker) @@ -3426,7 +3317,7 @@ go to the end of the last sexp, or if that is the same point, then step." (message "%s is already instrumented." func) func) (t - (let ((loc (find-function-noselect func))) + (let ((loc (find-function-noselect func t))) (unless (cdr loc) (error "Could not find the definition in its file")) (with-current-buffer (car loc) @@ -3446,7 +3337,7 @@ function or macro is called, Edebug will be called there as well." (save-excursion (down-list 1) (if (looking-at "\(") - (edebug-form-data-name + (edebug--form-data-name (edebug-get-form-data-entry (point))) (edebug-original-read (current-buffer)))))) (edebug-instrument-function func)))) @@ -3466,7 +3357,7 @@ instrumented. Then it does `edebug-on-entry' and switches to `go' mode." (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." +canceled 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))) @@ -3559,11 +3450,10 @@ edebug-mode." ;;; Evaluation of expressions -(def-edebug-spec edebug-outside-excursion t) - (defmacro edebug-outside-excursion (&rest body) "Evaluate an expression list in the outside context. Return the result of the last expression." + (declare (debug t)) `(save-excursion ; of current-buffer (if edebug-save-windows (progn @@ -3582,7 +3472,6 @@ Return the result of the last expression." (last-command-event edebug-outside-last-command-event) (last-command edebug-outside-last-command) (this-command edebug-outside-this-command) - (unread-command-char edebug-outside-unread-command-char) (unread-command-events edebug-outside-unread-command-events) (current-prefix-arg edebug-outside-current-prefix-arg) (last-input-event edebug-outside-last-input-event) @@ -3598,7 +3487,7 @@ Return the result of the last expression." (pre-command-hook (cdr edebug-outside-pre-command-hook)) (post-command-hook (cdr edebug-outside-post-command-hook)) - ;; See edebug-display + ;; See edebug-display. (overlay-arrow-position edebug-outside-o-a-p) (overlay-arrow-string edebug-outside-o-a-s) (cursor-in-echo-area edebug-outside-c-i-e-a) @@ -3622,7 +3511,6 @@ Return the result of the last expression." edebug-outside-last-command-event last-command-event edebug-outside-last-command last-command edebug-outside-this-command this-command - edebug-outside-unread-command-char unread-command-char edebug-outside-unread-command-events unread-command-events edebug-outside-current-prefix-arg current-prefix-arg edebug-outside-last-input-event last-input-event @@ -3653,17 +3541,19 @@ Return the result of the last expression." (defvar cl-debug-env) ; defined in cl; non-nil when lexical env used. -(defun edebug-eval (edebug-expr) +(defun edebug-eval (expr) ;; Are there cl lexical variables active? - (if (bound-and-true-p cl-debug-env) - (eval (cl-macroexpand-all edebug-expr cl-debug-env)) - (eval edebug-expr))) + (eval (if (and (bound-and-true-p cl-debug-env) + (fboundp 'cl-macroexpand-all)) + (cl-macroexpand-all expr cl-debug-env) + expr) + lexical-binding)) -(defun edebug-safe-eval (edebug-expr) +(defun edebug-safe-eval (expr) ;; Evaluate EXPR safely. ;; If there is an error, a string is returned describing the error. (condition-case edebug-err - (edebug-eval edebug-expr) + (edebug-eval expr) (error (edebug-format "%s: %s" ;; could (get (car edebug-err) 'error-message) (car (cdr edebug-err)))))) @@ -3671,17 +3561,17 @@ Return the result of the last expression." ;;; Printing -(defun edebug-report-error (edebug-value) +(defun edebug-report-error (value) ;; Print an error message like command level does. ;; This also prints the error name if it has no error-message. (message "%s: %s" - (or (get (car edebug-value) 'error-message) - (format "peculiar error (%s)" (car edebug-value))) + (or (get (car value) 'error-message) + (format "peculiar error (%s)" (car value))) (mapconcat (function (lambda (edebug-arg) ;; continuing after an error may ;; complain about edebug-arg. why?? (prin1-to-string edebug-arg))) - (cdr edebug-value) ", "))) + (cdr value) ", "))) (defvar print-readably) ; defined by lemacs ;; Alternatively, we could change the definition of @@ -3697,14 +3587,14 @@ Return the result of the last expression." (edebug-prin1-to-string value) (error "#Apparently circular structure#")))) -(defun edebug-compute-previous-result (edebug-previous-value) +(defun edebug-compute-previous-result (previous-value) (if edebug-unwrap-results - (setq edebug-previous-value - (edebug-unwrap* edebug-previous-value))) + (setq previous-value + (edebug-unwrap* previous-value))) (setq edebug-previous-result (concat "Result: " - (edebug-safe-prin1-to-string edebug-previous-value) - (eval-expression-print-format edebug-previous-value)))) + (edebug-safe-prin1-to-string previous-value) + (eval-expression-print-format previous-value)))) (defun edebug-previous-result () "Print the previous result." @@ -3719,7 +3609,7 @@ Return the result of the last expression." (defalias 'edebug-format 'format) (defalias 'edebug-message 'message) -(defun edebug-eval-expression (edebug-expr) +(defun edebug-eval-expression (expr) "Evaluate an expression in the outside environment. If interactive, prompt for the expression. Print result in minibuffer." @@ -3728,7 +3618,7 @@ Print result in minibuffer." 'read-expression-history))) (princ (edebug-outside-excursion - (setq values (cons (edebug-eval edebug-expr) values)) + (setq values (cons (edebug-eval expr) values)) (concat (edebug-safe-prin1-to-string (car values)) (eval-expression-print-format (car values)))))) @@ -3742,25 +3632,29 @@ Print value in minibuffer." "Evaluate sexp before point in outside environment; insert value. This prints the value into current buffer." (interactive) - (let* ((edebug-form (edebug-last-sexp)) - (edebug-result-string + (let* ((form (edebug-last-sexp)) + (result-string (edebug-outside-excursion - (edebug-safe-prin1-to-string (edebug-safe-eval edebug-form)))) + (edebug-safe-prin1-to-string (edebug-safe-eval form)))) (standard-output (current-buffer))) (princ "\n") ;; princ the string to get rid of quotes. - (princ edebug-result-string) + (princ result-string) (princ "\n") )) ;;; Edebug Minor Mode -;; FIXME eh? -(defvar gud-inhibit-global-bindings - "*Non-nil means don't do global rebindings of C-x C-a subcommands.") +(defvar edebug-inhibit-emacs-lisp-mode-bindings nil + "If non-nil, inhibit Edebug bindings on the C-x C-a key. +By default, loading the `edebug' library causes these bindings to +be installed in `emacs-lisp-mode-map'.") + +(define-obsolete-variable-alias 'gud-inhibit-global-bindings + 'edebug-inhibit-emacs-lisp-mode-bindings "24.3") ;; Global GUD bindings for all emacs-lisp-mode buffers. -(unless gud-inhibit-global-bindings +(unless edebug-inhibit-emacs-lisp-mode-bindings (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) @@ -3896,24 +3790,23 @@ 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 -" +`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'" ;; If the user kills the buffer in which edebug is currently active, ;; exit to top level, because the edebug command loop can't usefully ;; continue running in such a case. @@ -3938,44 +3831,38 @@ edebug-global-break-condition (edebug-trace nil)) (mapcar 'edebug-safe-eval edebug-eval-list))) -(defun edebug-eval-display-list (edebug-eval-result-list) +(defun edebug-eval-display-list (eval-result-list) ;; Assumes edebug-eval-buffer exists. - (let ((edebug-eval-list-temp edebug-eval-list) - (standard-output edebug-eval-buffer) + (let ((standard-output edebug-eval-buffer) (edebug-comment-line (format ";%s\n" (make-string (- (window-width) 2) ?-)))) (set-buffer edebug-eval-buffer) (erase-buffer) - (while edebug-eval-list-temp - (prin1 (car edebug-eval-list-temp)) (terpri) - (prin1 (car edebug-eval-result-list)) (terpri) - (princ edebug-comment-line) - (setq edebug-eval-list-temp (cdr edebug-eval-list-temp)) - (setq edebug-eval-result-list (cdr edebug-eval-result-list))) + (dolist (exp edebug-eval-list) + (prin1 exp) (terpri) + (prin1 (pop eval-result-list)) (terpri) + (princ edebug-comment-line)) (edebug-pop-to-buffer edebug-eval-buffer) )) (defun edebug-create-eval-buffer () - (if (not (and edebug-eval-buffer (buffer-name edebug-eval-buffer))) - (progn - (set-buffer (setq edebug-eval-buffer (get-buffer-create "*edebug*"))) - (edebug-eval-mode)))) + (unless (and edebug-eval-buffer (buffer-name edebug-eval-buffer)) + (set-buffer (setq edebug-eval-buffer (get-buffer-create "*edebug*"))) + (edebug-eval-mode))) ;; Should generalize this to be callable outside of edebug ;; with calls in user functions, e.g. (edebug-eval-display) -(defun edebug-eval-display (edebug-eval-result-list) - "Display expressions and evaluations in EDEBUG-EVAL-RESULT-LIST. +(defun edebug-eval-display (eval-result-list) + "Display expressions and evaluations in EVAL-RESULT-LIST. It modifies the context by popping up the eval display." - (if edebug-eval-result-list - (progn - (edebug-create-eval-buffer) - (edebug-eval-display-list edebug-eval-result-list) - ))) + (when eval-result-list + (edebug-create-eval-buffer) + (edebug-eval-display-list eval-result-list))) (defun edebug-eval-redisplay () "Redisplay eval list in outside environment. -May only be called from within `edebug-recursive-edit'." +May only be called from within `edebug--recursive-edit'." (edebug-create-eval-buffer) (edebug-outside-excursion (edebug-eval-display-list (edebug-eval-result-list)) @@ -3999,7 +3886,7 @@ May only be called from within `edebug-recursive-edit'." (if (not (eobp)) (progn (forward-sexp 1) - (setq new-list (cons (edebug-last-sexp) new-list)))) + (push (edebug-last-sexp) new-list))) (while (re-search-forward "^;" nil t) (forward-line 1) @@ -4008,7 +3895,7 @@ May only be called from within `edebug-recursive-edit'." (not (eobp))) (progn (forward-sexp 1) - (setq new-list (cons (edebug-last-sexp) new-list))))) + (push (edebug-last-sexp) new-list)))) (setq edebug-eval-list (nreverse new-list)) (edebug-eval-redisplay) @@ -4029,19 +3916,17 @@ May only be called from within `edebug-recursive-edit'." -(defvar edebug-eval-mode-map nil +(defvar edebug-eval-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map lisp-interaction-mode-map) + (define-key map "\C-c\C-w" 'edebug-where) + (define-key map "\C-c\C-d" 'edebug-delete-eval-item) + (define-key map "\C-c\C-u" 'edebug-update-eval-list) + (define-key map "\C-x\C-e" 'edebug-eval-last-sexp) + (define-key map "\C-j" 'edebug-eval-print-last-sexp) + map) "Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.") -(unless edebug-eval-mode-map - (setq edebug-eval-mode-map (make-sparse-keymap)) - (set-keymap-parent edebug-eval-mode-map 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)) - (put 'edebug-eval-mode 'mode-class 'special) (define-derived-mode edebug-eval-mode lisp-interaction-mode "Edebug Eval" @@ -4067,32 +3952,32 @@ Global commands prefixed by `global-edebug-prefix': ;; since they depend on the backtrace looking a certain way. But ;; edebug is not dependent on this, yet. -(defun edebug (&optional edebug-arg-mode &rest debugger-args) +(defun edebug (&optional arg-mode &rest args) "Replacement for `debug'. If we are running an edebugged function, show where we last were. Otherwise call `debug' normally." -;; (message "entered: %s depth: %s edebug-recursion-depth: %s" -;; edebug-entered (recursion-depth) edebug-recursion-depth) (sit-for 1) + ;;(message "entered: %s depth: %s edebug-recursion-depth: %s" + ;; edebug-entered (recursion-depth) edebug-recursion-depth) (sit-for 1) (if (and edebug-entered ; anything active? (eq (recursion-depth) edebug-recursion-depth)) (let (;; Where were we before the error occurred? - (edebug-offset-index (car edebug-offset-indices)) - ;; Bind variables required by edebug-display - (edebug-value (car debugger-args)) + (offset-index (car edebug-offset-indices)) + (value (car args)) + ;; Bind variables required by edebug--display. edebug-breakpoints edebug-break-data edebug-break-condition edebug-global-break - (edebug-break (null edebug-arg-mode)) ;; if called explicitly + (edebug-break (null arg-mode)) ;; If called explicitly. ) - (edebug-display) - (if (eq edebug-arg-mode 'error) + (edebug--display value offset-index arg-mode) + (if (eq arg-mode 'error) nil - edebug-value)) + value)) ;; Otherwise call debug normally. ;; Still need to remove extraneous edebug calls from stack. - (apply 'debug edebug-arg-mode debugger-args) + (apply 'debug arg-mode args) )) @@ -4103,7 +3988,7 @@ Otherwise call `debug' normally." (null (buffer-name edebug-backtrace-buffer))) (setq edebug-backtrace-buffer (generate-new-buffer "*Backtrace*")) - ;; else, could just display edebug-backtrace-buffer + ;; Else, could just display edebug-backtrace-buffer. ) (with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer) (setq edebug-backtrace-buffer standard-output) @@ -4125,7 +4010,7 @@ Otherwise call `debug' normally." (beginning-of-line) (cond ((looking-at "^ \(edebug-after") - ;; Previous lines may contain code, so just delete this line + ;; Previous lines may contain code, so just delete this line. (setq last-ok-point (point)) (forward-line 1) (delete-region last-ok-point (point))) @@ -4143,15 +4028,15 @@ Otherwise call `debug' normally." "In buffer BUF-NAME, display FMT and ARGS at the end and make it visible. The buffer is created if it does not exist. You must include newlines in FMT to break lines, but one newline is appended." -;; e.g. -;; (edebug-trace-display "*trace-point*" -;; "saving: point = %s window-start = %s" -;; (point) (window-start)) + ;; e.g. + ;; (edebug-trace-display "*trace-point*" + ;; "saving: point = %s window-start = %s" + ;; (point) (window-start)) (let* ((oldbuf (current-buffer)) (selected-window (selected-window)) (buffer (get-buffer-create buf-name)) buf-window) -;; (message "before pop-to-buffer") (sit-for 1) + ;; (message "before pop-to-buffer") (sit-for 1) (edebug-pop-to-buffer buffer) (setq truncate-lines t) (setq buf-window (selected-window)) @@ -4161,8 +4046,8 @@ You must include newlines in FMT to break lines, but one newline is appended." (vertical-motion (- 1 (window-height))) (set-window-start buf-window (point)) (goto-char (point-max)) -;; (set-window-point buf-window (point)) -;; (edebug-sit-for 0) + ;; (set-window-point buf-window (point)) + ;; (sit-for 0) (bury-buffer buffer) (select-window selected-window) (set-buffer oldbuf)) @@ -4177,6 +4062,8 @@ You must include newlines in FMT to break lines, but one newline is appended." ;;; Frequency count and coverage ;; FIXME should this use overlays instead? +;; Definitely, IMO. The current business with undo in +;; edebug-temp-display-freq-count is horrid. (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, @@ -4223,8 +4110,8 @@ reinstrument it." ;; Insert all the indices for this line. (forward-line 1) (setq start-of-count-line (point) - first-index i ; really last index for line above this one. - last-count -1) ; cause first count to always appear. + first-index i ; Really, last index for line above this one. + last-count -1) ; Cause first count to always appear. (insert ";#") ;; i == first-index still (while (<= (setq i (1+ i)) last-index) @@ -4246,6 +4133,8 @@ reinstrument it." (insert "\n") (setq i first-index))))) +;; FIXME this does not work very well. Eg if you press an arrow key, +;; or make a mouse-click, it fails with "Non-character input-event". (defun edebug-temp-display-freq-count () "Temporarily display the frequency count data for the current definition. It is removed when you hit any char." @@ -4254,15 +4143,17 @@ It is removed when you hit any char." (let ((buffer-read-only nil)) (undo-boundary) (edebug-display-freq-count) - (setq unread-command-char (read-char)) + (setq unread-command-events + (append unread-command-events (list (read-event)))) + ;; Yuck! This doesn't seem to work at all for me. (undo))) ;;; Menus (defun edebug-toggle (variable) - (set variable (not (eval variable))) - (message "%s: %s" variable (eval variable))) + (set variable (not (symbol-value variable))) + (message "%s: %s" variable (symbol-value variable))) ;; We have to require easymenu (even for Emacs 18) just so ;; the easy-menu-define macro call is compiled correctly. @@ -4365,97 +4256,9 @@ With prefix argument, make it a temporary breakpoint." (easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus) -;;; Byte-compiler - -;; Extension for bytecomp to resolve undefined function references. -;; Requires new byte compiler. - -;; Reenable byte compiler warnings about unread-command-char and -event. -;; Disabled before edebug-recursive-edit. -(eval-when-compile - (if edebug-unread-command-char-warning - (put 'unread-command-char 'byte-obsolete-variable - edebug-unread-command-char-warning))) - -(eval-when-compile - ;; The body of eval-when-compile seems to get evaluated with eval-defun. - ;; We only want to evaluate when actually byte compiling. - ;; But it is OK to evaluate as long as byte-compiler has been loaded. - (if (featurep 'byte-compile) (progn - - (defun byte-compile-resolve-functions (funcs) - "Say it is OK for the named functions to be unresolved." - (mapc - (function - (lambda (func) - (setq byte-compile-unresolved-functions - (delq (assq func byte-compile-unresolved-functions) - byte-compile-unresolved-functions)))) - funcs) - nil) - - '(defun byte-compile-resolve-free-references (vars) - "Say it is OK for the named variables to be referenced." - (mapcar - (function - (lambda (var) - (setq byte-compile-free-references - (delq var byte-compile-free-references)))) - vars) - nil) - - '(defun byte-compile-resolve-free-assignments (vars) - "Say it is OK for the named variables to be assigned." - (mapcar - (function - (lambda (var) - (setq byte-compile-free-assignments - (delq var byte-compile-free-assignments)))) - vars) - nil) - - (byte-compile-resolve-functions - '(reporter-submit-bug-report - edebug-gensym ;; also in cl.el - ;; Interfaces to standard functions. - edebug-original-eval-defun - edebug-original-read - edebug-get-buffer-window - edebug-mark - edebug-mark-marker - edebug-input-pending-p - edebug-sit-for - edebug-prin1-to-string - edebug-format - ;; lemacs - zmacs-deactivate-region - popup-menu - ;; CL - cl-macroexpand-all - ;; And believe it or not, the byte compiler doesn't know about: - byte-compile-resolve-functions - )) - - '(byte-compile-resolve-free-references - '(read-expression-history - read-expression-map)) - - '(byte-compile-resolve-free-assignments - '(read-expression-history)) - - ))) - - ;;; Autoloading of Edebug accessories -(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 +;; 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)))) @@ -4466,13 +4269,12 @@ With prefix argument, make it a temporary breakpoint." ;;; Finalize Loading -;;; Finally, hook edebug into the rest of Emacs. -;;; There are probably some other things that could go here. +;; 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) -;; arch-tag: 19c8d05c-4554-426e-ac72-e0fa1fcb0808 ;;; edebug.el ends here diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 34bc18540df..24d680181bb 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -1,11 +1,11 @@ ;;; eieio-base.el --- Base classes for EIEIO. -;;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007, 2008, 2009, 2010, 2011, 2012 -;;; Free Software Foundation, Inc. +;;; Copyright (C) 2000-2002, 2004-2005, 2007-2013 Free Software +;;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. @@ -53,7 +53,7 @@ not been set, use values from the parent." (defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn) "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal. -SLOT-NAME is the offending slot. FN is the function signalling the error." +SLOT-NAME is the offending slot. FN is the function signaling the error." (if (slot-boundp object 'parent-instance) ;; It may not look like it, but this line recurses back into this ;; method if the parent instance's slot is unbound. @@ -177,7 +177,7 @@ only one object ever exists." ;; calculate path names relative to a given instance. This will ;; make the saved object location independent by converting all file ;; references to be relative to the directory the object is saved to. -;; You must call `eieio-peristent-path-relative' on each file name +;; You must call `eieio-persistent-path-relative' on each file name ;; saved in your object. (defclass eieio-persistent () ((file :initarg :file @@ -224,8 +224,16 @@ a file. Optional argument NAME specifies a default file name." )))) (oref this file)) -(defun eieio-persistent-read (filename) - "Read a persistent object from FILENAME, and return it." +(defun eieio-persistent-read (filename &optional class allow-subclass) + "Read a persistent object from FILENAME, and return it. +Signal an error if the object in FILENAME is not a constructor +for CLASS. Optional ALLOW-SUBCLASS says that it is ok for +`eieio-persistent-read' to load in subclasses of class instead of +being pedantic." + (unless class + (message "Unsafe call to `eieio-persistent-read'.")) + (when (and class (not (class-p class))) + (signal 'wrong-type-argument (list 'class-p class))) (let ((ret nil) (buffstr nil)) (unwind-protect @@ -238,13 +246,171 @@ a file. Optional argument NAME specifies a default file name." ;; so that any initialize-instance calls that depend on ;; the current buffer will work. (setq ret (read buffstr)) - (if (not (child-of-class-p (car ret) 'eieio-persistent)) - (error "Corrupt object on disk")) - (setq ret (eval ret)) + (when (not (child-of-class-p (car ret) 'eieio-persistent)) + (error "Corrupt object on disk: Unknown saved object")) + (when (and class + (not (or (eq (car ret) class ) ; same class + (and allow-subclass + (child-of-class-p (car ret) class)) ; subclasses + ))) + (error "Corrupt object on disk: Invalid saved class")) + (setq ret (eieio-persistent-convert-list-to-object ret)) (oset ret file filename)) (kill-buffer " *tmp eieio read*")) ret)) +(defun eieio-persistent-convert-list-to-object (inputlist) + "Convert the INPUTLIST, representing object creation to an object. +While it is possible to just `eval' the INPUTLIST, this code instead +validates the existing list, and explicitly creates objects instead of +calling eval. This avoids the possibility of accidentally running +malicious code. + +Note: This function recurses when a slot of :type of some object is +identified, and needing more object creation." + (let ((objclass (nth 0 inputlist)) + (objname (nth 1 inputlist)) + (slots (nthcdr 2 inputlist)) + (createslots nil)) + + ;; If OBJCLASS is an eieio autoload object, then we need to load it. + (eieio-class-un-autoload objclass) + + (while slots + (let ((name (car slots)) + (value (car (cdr slots)))) + + ;; Make sure that the value proposed for SLOT is valid. + ;; In addition, strip out quotes, list functions, and update + ;; object constructors as needed. + (setq value (eieio-persistent-validate/fix-slot-value + objclass name value)) + + (push name createslots) + (push value createslots) + ) + + (setq slots (cdr (cdr slots)))) + + (apply 'make-instance objclass objname (nreverse createslots)) + + ;;(eval inputlist) + )) + +(defun eieio-persistent-validate/fix-slot-value (class slot proposed-value) + "Validate that in CLASS, the SLOT with PROPOSED-VALUE is good, then fix. +A limited number of functions, such as quote, list, and valid object +constructor functions are considered valid. +Second, any text properties will be stripped from strings." + (cond ((consp proposed-value) + ;; Lists with something in them need special treatment. + (let ((slot-idx (eieio-slot-name-index class nil slot)) + (type nil) + (classtype nil)) + (setq slot-idx (- slot-idx 3)) + (setq type (aref (aref (class-v class) class-public-type) + slot-idx)) + + (setq classtype (eieio-persistent-slot-type-is-class-p + type)) + + (cond ((eq (car proposed-value) 'quote) + (car (cdr proposed-value))) + + ;; An empty list sometimes shows up as (list), which is dumb, but + ;; we need to support it for backward compat. + ((and (eq (car proposed-value) 'list) + (= (length proposed-value) 1)) + nil) + + ;; We have a slot with a single object that can be + ;; saved here. Recurse and evaluate that + ;; sub-object. + ((and classtype (class-p classtype) + (child-of-class-p (car proposed-value) classtype)) + (eieio-persistent-convert-list-to-object + proposed-value)) + + ;; List of object constructors. + ((and (eq (car proposed-value) 'list) + ;; 2nd item is a list. + (consp (car (cdr proposed-value))) + ;; 1st elt of 2nd item is a class name. + (class-p (car (car (cdr proposed-value)))) + ) + + ;; Check the value against the input class type. + ;; If something goes wrong, issue a smart warning + ;; about how a :type is needed for this to work. + (unless (and + ;; Do we have a type? + (consp classtype) (class-p (car classtype))) + (error "In save file, list of object constructors found, but no :type specified for slot %S" + slot)) + + ;; We have a predicate, but it doesn't satisfy the predicate? + (dolist (PV (cdr proposed-value)) + (unless (child-of-class-p (car PV) (car classtype)) + (error "Corrupt object on disk"))) + + ;; We have a list of objects here. Lets load them + ;; in. + (let ((objlist nil)) + (dolist (subobj (cdr proposed-value)) + (push (eieio-persistent-convert-list-to-object subobj) + objlist)) + ;; return the list of objects ... reversed. + (nreverse objlist))) + (t + proposed-value)))) + + ((stringp proposed-value) + ;; Else, check for strings, remove properties. + (substring-no-properties proposed-value)) + + (t + ;; Else, just return whatever the constant was. + proposed-value)) + ) + +(defun eieio-persistent-slot-type-is-class-p (type) + "Return the class refered to in TYPE. +If no class is referenced there, then return nil." + (cond ((class-p type) + ;; If the type is a class, then return it. + type) + + ((and (symbolp type) (string-match "-child$" (symbol-name type)) + (class-p (intern-soft (substring (symbol-name type) 0 + (match-beginning 0))))) + ;; If it is the predicate ending with -child, then return + ;; that class. Unfortunately, in EIEIO, typep of just the + ;; class is the same as if we used -child, so no further work needed. + (intern-soft (substring (symbol-name type) 0 + (match-beginning 0)))) + + ((and (symbolp type) (string-match "-list$" (symbol-name type)) + (class-p (intern-soft (substring (symbol-name type) 0 + (match-beginning 0))))) + ;; If it is the predicate ending with -list, then return + ;; that class and the predicate to use. + (cons (intern-soft (substring (symbol-name type) 0 + (match-beginning 0))) + type)) + + ((and (consp type) (eq (car type) 'or)) + ;; If type is a list, and is an or, it is possibly something + ;; like (or null myclass), so check for that. + (let ((ans nil)) + (dolist (subtype (cdr type)) + (setq ans (eieio-persistent-slot-type-is-class-p + subtype))) + ans)) + + (t + ;; No match, not a class. + nil))) + (defmethod object-write ((this eieio-persistent) &optional comment) "Write persistent object THIS out to the current stream. Optional argument COMMENT is a header line comment." @@ -328,5 +494,4 @@ a set type." (provide 'eieio-base) -;; arch-tag: 6260571e-9e8a-41a0-880f-a937b0c2ea8b ;;; eieio-base.el ends here diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el deleted file mode 100644 index 3bbe5981c6d..00000000000 --- a/lisp/emacs-lisp/eieio-comp.el +++ /dev/null @@ -1,142 +0,0 @@ -;;; eieio-comp.el -- eieio routines to help with byte compilation - -;; Copyright (C) 1995,1996, 1998, 1999, 2000, 2001, 2002, 2005, 2008, -;; 2009, 2010, 2011, 2012 Free Software Foundation, Inc. - -;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 -;; Keywords: oop, 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 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Byte compiler functions for defmethod. This will affect the new GNU -;; byte compiler for Emacs 19 and better. This function will be called by -;; the byte compiler whenever a `defmethod' is encountered in a file. -;; It will output a function call to `eieio-defmethod' with the byte -;; compiled function as a parameter. - -;;; Code: - -(declare-function eieio-defgeneric-form "eieio" (method doc-string)) - -;; Some compatibility stuff -(eval-and-compile - (if (not (fboundp 'byte-compile-compiled-obj-to-list)) - (defun byte-compile-compiled-obj-to-list (moose) nil)) - - (if (not (boundp 'byte-compile-outbuffer)) - (defvar byte-compile-outbuffer nil)) - ) - -;; This teaches the byte compiler how to do this sort of thing. -(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) - -;; Variables used free: -(defvar outbuffer) -(defvar filename) - -(defun byte-compile-file-form-defmethod (form) - "Mumble about the method we are compiling. -This function is mostly ripped from `byte-compile-file-form-defun', -but it's been modified to handle the special syntax of the `defmethod' -command. There should probably be one for `defgeneric' as well, but -that is called but rarely. Argument FORM is the body of the method." - (setq form (cdr form)) - (let* ((meth (car form)) - (key (progn (setq form (cdr form)) - (cond ((or (eq ':BEFORE (car form)) - (eq ':before (car form))) - (setq form (cdr form)) - ":before ") - ((or (eq ':AFTER (car form)) - (eq ':after (car form))) - (setq form (cdr form)) - ":after ") - ((or (eq ':PRIMARY (car form)) - (eq ':primary (car form))) - (setq form (cdr form)) - ":primary ") - ((or (eq ':STATIC (car form)) - (eq ':static (car form))) - (setq form (cdr form)) - ":static ") - (t "")))) - (params (car form)) - (lamparams (byte-compile-defmethod-param-convert params)) - (arg1 (car params)) - (class (if (listp arg1) (nth 1 arg1) nil)) - (my-outbuffer (if (eval-when-compile (featurep 'xemacs)) - byte-compile-outbuffer - (condition-case nil - bytecomp-outbuffer - (error outbuffer)))) - ) - (let ((name (format "%s::%s" (or class "#<generic>") meth))) - (if byte-compile-verbose - ;; #### filename used free - (message "Compiling %s... (%s)" (or filename "") name)) - (setq byte-compile-current-form name) ; for warnings - ) - ;; Flush any pending output - (byte-compile-flush-pending) - ;; Byte compile the body. For the byte compiled forms, add the - ;; rest arguments, which will get ignored by the engine which will - ;; add them later (I hope) - (let* ((new-one (byte-compile-lambda - (append (list 'lambda lamparams) - (cdr form)))) - (code (byte-compile-byte-code-maker new-one))) - (princ "\n(eieio-defmethod '" my-outbuffer) - (princ meth my-outbuffer) - (princ " '(" my-outbuffer) - (princ key my-outbuffer) - (prin1 params my-outbuffer) - (princ " " my-outbuffer) - (prin1 code my-outbuffer) - (princ "))" my-outbuffer) - ) - ;; Now add this function to the list of known functions. - ;; Don't bother with a doc string. Not relevant here. - (add-to-list 'byte-compile-function-environment - (cons meth - (eieio-defgeneric-form meth ""))) - - ;; Remove it from the undefined list if it is there. - (let ((elt (assq meth byte-compile-unresolved-functions))) - (if elt (setq byte-compile-unresolved-functions - (delq elt byte-compile-unresolved-functions)))) - - ;; nil prevents cruft from appearing in the output buffer. - nil)) - -(defun byte-compile-defmethod-param-convert (paramlist) - "Convert method params into the params used by the `defmethod' thingy. -Argument PARAMLIST is the parameter list to convert." - (let ((argfix nil)) - (while paramlist - (setq argfix (cons (if (listp (car paramlist)) - (car (car paramlist)) - (car paramlist)) - argfix)) - (setq paramlist (cdr paramlist))) - (nreverse argfix))) - -(provide 'eieio-comp) - -;; arch-tag: f2aacdd3-1da2-4ee9-b3e5-e8eac0832ee3 -;;; eieio-comp.el ends here diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 93076047ba6..46dc34d6d45 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -1,11 +1,12 @@ ;;; eieio-custom.el -- eieio object customization -;; Copyright (C) 1999, 2000, 2001, 2005, 2007, 2008, 2009, 2010, 2011, 2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 1999-2001, 2005, 2007-2013 Free Software Foundation, +;; Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. @@ -326,11 +327,22 @@ User made commands should also call this method when applying changes. Argument OBJ is the object that has been customized." nil) +;;;###autoload (defun customize-object (obj &optional group) "Customize OBJ in a custom buffer. Optional argument GROUP is the sub-group of slots to display." (eieio-customize-object obj group)) +(defvar eieio-custom-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map widget-keymap) + map) + "Keymap for EIEIO Custom mode") + +(define-derived-mode eieio-custom-mode fundamental-mode "EIEIO Custom" + "Major mode for customizing EIEIO objects. +\\{eieio-custom-mode-map}") + (defmethod eieio-customize-object ((obj eieio-default-superclass) &optional group) "Customize OBJ in a specialized custom buffer. @@ -344,8 +356,9 @@ These groups are specified with the `:group' slot flag." (concat "*CUSTOMIZE " (object-name obj) " " (symbol-name g) "*"))) - (toggle-read-only -1) + (setq buffer-read-only nil) (kill-all-local-variables) + (eieio-custom-mode) (erase-buffer) (let ((all (overlay-lists))) ;; Delete all the overlays. @@ -362,7 +375,6 @@ These groups are specified with the `:group' slot flag." (widget-insert "\n") (eieio-custom-object-apply-reset obj) ;; Now initialize the buffer - (use-local-map widget-keymap) (widget-setup) ;;(widget-minor-mode) (goto-char (point-min)) @@ -460,5 +472,4 @@ Return the symbol for the group, or nil" (provide 'eieio-custom) -;; arch-tag: bc122762-a771-48d5-891b-7835b16dd924 ;;; eieio-custom.el ends here diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 6f572bdc215..e23bbb07fe2 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -1,9 +1,10 @@ ;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -;; Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2007-2013 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. @@ -91,12 +92,11 @@ PREBUTTONTEXT is some text between PREFIX and the object button." "Class: ") ;; Loop over all the public slots (let ((publa (aref cv class-public-a)) - (publd (aref cv class-public-d)) ) (while publa (if (slot-boundp obj (car publa)) - (let ((i (class-slot-initarg cl (car publa))) - (v (eieio-oref obj (car publa)))) + (let* ((i (class-slot-initarg cl (car publa))) + (v (eieio-oref obj (car publa)))) (data-debug-insert-thing v prefix (concat (if i (symbol-name i) @@ -111,7 +111,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button." " ") 'font-lock-keyword-face)) ) - (setq publa (cdr publa) publd (cdr publd)))))) + (setq publa (cdr publa)))))) ;;; Augment the Data debug thing display list. (data-debug-add-specialized-thing (lambda (thing) (object-p thing)) @@ -131,7 +131,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button." (defun eieio-debug-methodinvoke (method class) "Show the method invocation order for METHOD with CLASS object." (interactive "aMethod: \nXClass Expression: ") - (let* ((eieio-pre-method-execution-hooks + (let* ((eieio-pre-method-execution-functions (lambda (l) (throw 'moose l) )) (data (catch 'moose (eieio-generic-call @@ -144,5 +144,4 @@ PREBUTTONTEXT is some text between PREFIX and the object button." (provide 'eieio-datadebug) -;; arch-tag: 6c7c2890-7614-41b0-816b-c61f3f6a8130 ;;; eieio-datadebug.el ends here diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 9b56d1c6011..8867d88cc3a 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -1,11 +1,11 @@ ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2008, -;; 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1998-2003, 2005, 2008-2013 Free Software +;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. @@ -29,8 +29,12 @@ ;; (require 'eieio) +(require 'find-func) +(require 'speedbar) +(require 'help-mode) ;;; Code: +;;;###autoload (defun eieio-browse (&optional root-class) "Create an object browser window to show all objects. If optional ROOT-CLASS, then start with that, otherwise start with @@ -70,8 +74,9 @@ Argument CH-PREFIX is another character prefix to display." ;;; CLASS COMPLETION / DOCUMENTATION -(defalias 'describe-class 'eieio-describe-class) +;;;###autoload(defalias 'describe-class 'eieio-describe-class) +;;;###autoload (defun eieio-describe-class (class &optional headerfcn) "Describe a CLASS defined by a string or symbol. If CLASS is actually an object, then also display current values of that object. @@ -82,13 +87,18 @@ Optional HEADERFCN should be called to insert a few bits of info first." (called-interactively-p 'interactive)) (when headerfcn (funcall headerfcn)) - - (if (class-option class :abstract) - (princ "Abstract ")) - (princ "Class ") (prin1 class) + (princ " is a") + (if (class-option class :abstract) + (princ "n abstract")) + (princ " class") + ;; Print file location + (when (get class 'class-location) + (princ " in `") + (princ (file-name-nondirectory (get class 'class-location))) + (princ "'")) (terpri) - ;; Inheritence tree information + ;; Inheritance tree information (let ((pl (class-parents class))) (when pl (princ " Inherits from ") @@ -237,6 +247,7 @@ Outputs to the standard output." prot (cdr prot) i (1+ i))))) +;;;###autoload (defun eieio-describe-constructor (fcn) "Describe the constructor function FCN. Uses `eieio-describe-class' to describe the class being constructed." @@ -247,8 +258,13 @@ Uses `eieio-describe-class' to describe the class being constructed." (eieio-describe-class fcn (lambda () ;; Describe the constructor part. - (princ "Object Constructor Function: ") (prin1 fcn) + (princ " is an object constructor function") + ;; Print file location + (when (get fcn 'class-location) + (princ " in `") + (princ (file-name-nondirectory (get fcn 'class-location))) + (princ "'")) (terpri) (princ "Creates an object of class ") (prin1 fcn) @@ -258,6 +274,16 @@ Uses `eieio-describe-class' to describe the class being constructed." )) ) +(defun eieio-build-class-list (class) + "Return a list of all classes that inherit from CLASS." + (if (class-p class) + (apply #'append + (mapcar + (lambda (c) + (append (list c) (eieio-build-class-list c))) + (class-children-fast class))) + (list class))) + (defun eieio-build-class-alist (&optional class instantiable-only buildlist) "Return an alist of all currently active classes for completion purposes. Optional argument CLASS is the class to start with. @@ -266,8 +292,9 @@ are not abstract, otherwise allow all classes. Optional argument BUILDLIST is more list to attach and is used internally." (let* ((cc (or class eieio-default-superclass)) (sublst (aref (class-v cc) class-children))) - (if (or (not instantiable-only) (not (class-abstract-p cc))) - (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))) + (unless (assoc (symbol-name cc) buildlist) + (when (or (not instantiable-only) (not (class-abstract-p cc))) + (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) (while sublst (setq buildlist (eieio-build-class-alist (car sublst) instantiable-only buildlist)) @@ -300,9 +327,10 @@ are not abstract." ;;; METHOD COMPLETION / DOC (defalias 'describe-method 'eieio-describe-generic) -(defalias 'describe-generic 'eieio-describe-generic) +;;;###autoload(defalias 'describe-generic 'eieio-describe-generic) (defalias 'eieio-describe-method 'eieio-describe-generic) +;;;###autoload (defun eieio-describe-generic (generic) "Describe the generic function GENERIC. Also extracts information about all methods specific to this generic." @@ -337,10 +365,10 @@ Also extracts information about all methods specific to this generic." (princ "Implementations:") (terpri) (terpri) - (let ((i 3) + (let ((i 4) (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) ;; Loop over fanciful generics - (while (< i 6) + (while (< i 7) (let ((gm (aref (get generic 'eieio-method-tree) i))) (when gm (princ "Generic ") @@ -352,8 +380,9 @@ Also extracts information about all methods specific to this generic." (setq i (1+ i))) (setq i 0) ;; Loop over defined class-specific methods - (while (< i 3) - (let ((gm (reverse (aref (get generic 'eieio-method-tree) i)))) + (while (< i 4) + (let ((gm (reverse (aref (get generic 'eieio-method-tree) i))) + location) (while gm (princ "`") (prin1 (car (car gm))) @@ -370,6 +399,13 @@ Also extracts information about all methods specific to this generic." ;; 3 because of cdr (princ (or (documentation (cdr (car gm))) "Undocumented")) + ;; Print file location if available + (when (and (setq location (get generic 'method-locations)) + (setq location (assoc (caar gm) location))) + (setq location (cadr location)) + (princ "\n\nDefined in `") + (princ (file-name-nondirectory location)) + (princ "'\n")) (setq gm (cdr gm)) (terpri) (terpri))) @@ -549,6 +585,65 @@ Optional argument HISTORYVAR is the variable to use as history." ;;; HELP AUGMENTATION ;; +(define-button-type 'eieio-method-def + :supertype 'help-xref + 'help-function (lambda (class method file) + (eieio-help-find-method-definition class method file)) + 'help-echo (purecopy "mouse-2, RET: find method's definition")) + +(define-button-type 'eieio-class-def + :supertype 'help-xref + 'help-function (lambda (class file) + (eieio-help-find-class-definition class file)) + 'help-echo (purecopy "mouse-2, RET: find class definition")) + +(defun eieio-help-find-method-definition (class method file) + (let ((filename (find-library-name file)) + location buf) + (when (null filename) + (error "Cannot find library %s" file)) + (setq buf (find-file-noselect filename)) + (with-current-buffer buf + (goto-char (point-min)) + (when + (re-search-forward + ;; Regexp for searching methods. + (concat "(defmethod[ \t\r\n]+" method + "\\([ \t\r\n]+:[a-zA-Z]+\\)?" + "[ \t\r\n]+(\\s-*(\\(\\sw\\|\\s_\\)+\\s-+" + class + "\\s-*)") + nil t) + (setq location (match-beginning 0)))) + (if (null location) + (message "Unable to find location in file") + (pop-to-buffer buf) + (goto-char location) + (recenter) + (beginning-of-line)))) + +(defun eieio-help-find-class-definition (class file) + (let ((filename (find-library-name file)) + location buf) + (when (null filename) + (error "Cannot find library %s" file)) + (setq buf (find-file-noselect filename)) + (with-current-buffer buf + (goto-char (point-min)) + (when + (re-search-forward + ;; Regexp for searching a class. + (concat "(defclass[ \t\r\n]+" class "[ \t\r\n]+") + nil t) + (setq location (match-beginning 0)))) + (if (null location) + (message "Unable to find location in file") + (pop-to-buffer buf) + (goto-char location) + (recenter) + (beginning-of-line)))) + + (defun eieio-help-mode-augmentation-maybee (&rest unused) "For buffers thrown into help mode, augment for EIEIO. Arguments UNUSED are not used." @@ -591,14 +686,30 @@ Arguments UNUSED are not used." (goto-char (point-min)) (while (re-search-forward "^\\(Private \\)?Slot:" nil t) (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) + (goto-char (point-min)) + (cond + ((looking-at "\\(.+\\) is a generic function") + (let ((mname (match-string 1)) + cname) + (while (re-search-forward "^`\\(.+\\)'[^\0]+?Defined in `\\(.+\\)'" nil t) + (setq cname (match-string-no-properties 1)) + (help-xref-button 2 'eieio-method-def cname + mname + (cadr (assoc (intern cname) + (get (intern mname) + 'method-locations))))))) + ((looking-at "\\(.+\\) is an object constructor function in `\\(.+\\)'") + (let ((cname (match-string-no-properties 1))) + (help-xref-button 2 'eieio-class-def cname + (get (intern cname) 'class-location)))) + ((looking-at "\\(.+\\) is a\\(n abstract\\)? class in `\\(.+\\)'") + (let ((cname (match-string-no-properties 1))) + (help-xref-button 3 'eieio-class-def cname + (get (intern cname) 'class-location))))) )))) ;;; SPEEDBAR SUPPORT ;; -(eval-when-compile - (condition-case nil - (require 'speedbar) - (error (message "Error loading speedbar... ignored")))) (defvar eieio-class-speedbar-key-map nil "Keymap used when working with a project in speedbar.") @@ -692,5 +803,4 @@ INDENT is the current indentation level." (provide 'eieio-opt) -;; arch-tag: 71eab5f5-462f-4fa1-8ed1-f5ca1bf9adb6 ;;; eieio-opt.el ends here diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index 4a8e200d1d5..27c7d01f3b8 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -1,11 +1,11 @@ ;;; eieio-speedbar.el -- Classes for managing speedbar displays. -;; Copyright (C) 1999, 2000, 2001, 2002, 2005, 2007, 2008, 2009, 2010, 2011, 2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 1999-2002, 2005, 2007-2013 Free Software Foundation, +;; Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 ;; Keywords: OO, tools +;; Package: eieio ;; This file is part of GNU Emacs. @@ -191,23 +191,24 @@ that path." ;;; DEFAULT SUPERCLASS baseline methods ;; -;; First, define methods onto the superclass so all classes -;; will have some minor support. +;; First, define methods with no class defined. These will work as if +;; on the default superclass. Specifying no class will allow these to be used +;; when no other methods are found, allowing multiple inheritance to work +;; reliably with eieio-speedbar. -(defmethod eieio-speedbar-description ((object eieio-default-superclass)) +(defmethod eieio-speedbar-description (object) "Return a string describing OBJECT." (object-name-string object)) -(defmethod eieio-speedbar-derive-line-path ((object eieio-default-superclass)) +(defmethod eieio-speedbar-derive-line-path (object) "Return the path which OBJECT has something to do with." nil) -(defmethod eieio-speedbar-object-buttonname ((object eieio-default-superclass)) +(defmethod eieio-speedbar-object-buttonname (object) "Return a string to use as a speedbar button for OBJECT." (object-name-string object)) -(defmethod eieio-speedbar-make-tag-line ((object eieio-default-superclass) - depth) +(defmethod eieio-speedbar-make-tag-line (object depth) "Insert a tag line into speedbar at point for OBJECT. By default, all objects appear as simple TAGS with no need to inherit from the special `eieio-speedbar' classes. Child classes should redefine this @@ -220,7 +221,7 @@ Argument DEPTH is the depth at which the tag line is inserted." 'speedbar-tag-face depth)) -(defmethod eieio-speedbar-handle-click ((object eieio-default-superclass)) +(defmethod eieio-speedbar-handle-click (object) "Handle a click action on OBJECT in speedbar. Any object can be represented as a tag in SPEEDBAR without special attributes. These default objects will be pulled up in a custom @@ -282,7 +283,7 @@ Add one of the child classes to this class to the parent list of a class." :abstract t) -;;; Methods to eieio-speedbar-* which do not need to be overriden +;;; Methods to eieio-speedbar-* which do not need to be overridden ;; (defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) depth) @@ -409,7 +410,7 @@ Optional DEPTH is the depth we start at." default-directory)))) -;;; Methods to the eieio-speedbar-* classes which need to be overriden. +;;; Methods to the eieio-speedbar-* classes which need to be overridden. ;; (defmethod eieio-speedbar-object-children ((object eieio-speedbar)) "Return a list of children to be displayed in speedbar. @@ -421,5 +422,4 @@ to create a speedbar button." (provide 'eieio-speedbar) -;; arch-tag: eaac1283-10b0-4419-a929-982b87e83234 ;;; eieio-speedbar.el ends here diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 3c8043f5b02..f112de13253 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -1,11 +1,10 @@ ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -;;; or maybe Eric's Implementation of Emacs Intrepreted Objects +;;; or maybe Eric's Implementation of Emacs Interpreted Objects -;; Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1995-1996, 1998-2013 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 1.3 +;; Version: 1.4 ;; Keywords: OO, lisp ;; This file is part of GNU Emacs. @@ -45,11 +44,9 @@ ;;; Code: -(eval-when-compile - (require 'cl) - (require 'eieio-comp)) +(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! -(defvar eieio-version "1.3" +(defvar eieio-version "1.4" "Current version of EIEIO.") (defun eieio-version () @@ -59,7 +56,7 @@ (eval-and-compile ;; About the above. EIEIO must process its own code when it compiles -;; itself, thus, by eval-and-compiling outselves, we solve the problem. +;; itself, thus, by eval-and-compiling ourselves, we solve the problem. ;; Compatibility (if (fboundp 'compiled-function-arglist) @@ -81,7 +78,7 @@ ;; (defvar eieio-hook nil - "*This hook is executed, then cleared each time `defclass' is called.") + "This hook is executed, then cleared each time `defclass' is called.") (defvar eieio-error-unsupported-class-tags nil "Non-nil to throw an error if an encountered tag is unsupported. @@ -89,7 +86,7 @@ This may prevent classes from CLOS applications from being used with EIEIO since EIEIO does not support all CLOS tags.") (defvar eieio-skip-typecheck nil - "*If non-nil, skip all slot typechecking. + "If non-nil, skip all slot typechecking. Set this to t permanently if a program is functioning well to get a small speed increase. This variable is also used internally to handle default setting for optimization purposes.") @@ -97,20 +94,6 @@ default setting for optimization purposes.") (defvar eieio-optimize-primary-methods-flag t "Non-nil means to optimize the method dispatch on primary methods.") -;; State Variables -(defvar this nil - "Inside a method, this variable is the object in question. -DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots. - -Note: Embedded methods are no longer supported. The variable THIS is -still set for CLOS methods for the sake of routines like -`call-next-method'.") - -(defvar scoped-class nil - "This is set to a class when a method is running. -This is so we know we are allowed to check private parts or how to -execute a `call-next-method'. DO NOT SET THIS YOURSELF!") - (defvar eieio-initializing-object nil "Set to non-nil while initializing an object.") @@ -124,6 +107,7 @@ execute a `call-next-method'. DO NOT SET THIS YOURSELF!") ;; while it is being built itself. (defvar eieio-default-superclass nil) +;; FIXME: The constants below should have an `eieio-' prefix added!! (defconst class-symbol 1 "Class's symbol (self-referencing.).") (defconst class-parent 2 "Class parent slot.") (defconst class-children 3 "Class children class slot.") @@ -182,10 +166,6 @@ Stored outright without modifications or stripping.") (t key) ;; already generic.. maybe. )) -;; How to specialty compile stuff. -(autoload 'byte-compile-file-form-defmethod "eieio-comp" - "This function is used to byte compile methods in a nice way.") -(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) ;;; Important macros used in eieio. ;; @@ -399,7 +379,7 @@ It creates an autoload function for CNAME's constructor." (aset newc class-parent (cons SC (aref newc class-parent))) ) - ;; turn this into a useable self-pointing symbol + ;; turn this into a usable self-pointing symbol (set cname cname) ;; Store the new class vector definition into the symbol. We need to @@ -415,6 +395,7 @@ It creates an autoload function for CNAME's constructor." (autoload cname filename doc nil nil) (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) + (autoload (intern (concat (symbol-name cname) "-list-p")) filename "" nil nil) )))) @@ -424,6 +405,7 @@ It creates an autoload function for CNAME's constructor." (load-library (car (cdr (symbol-function cname)))))) (defun eieio-defclass (cname superclasses slots options-and-doc) + ;; FIXME: Most of this should be moved to the `defclass' macro. "Define CNAME as a new subclass of SUPERCLASSES. SLOTS are the slots residing in that class definition, and options or documentation OPTIONS-AND-DOC is the toplevel documentation for this class. @@ -434,10 +416,10 @@ See `defclass' for more information." (run-hooks 'eieio-hook) (setq eieio-hook nil) - (if (not (symbolp cname)) (signal 'wrong-type-argument '(symbolp cname))) - (if (not (listp superclasses)) (signal 'wrong-type-argument '(listp superclasses))) + (if (not (listp superclasses)) + (signal 'wrong-type-argument '(listp superclasses))) - (let* ((pname (if superclasses superclasses nil)) + (let* ((pname superclasses) (newc (make-vector class-num-slots nil)) (oldc (when (class-p cname) (class-v cname))) (groups nil) ;; list of groups id'd from slots @@ -512,7 +494,7 @@ See `defclass' for more information." ;; save parent in child (aset newc class-parent (list eieio-default-superclass)))) - ;; turn this into a useable self-pointing symbol + ;; turn this into a usable self-pointing symbol (set cname cname) ;; These two tests must be created right away so we can have self- @@ -543,6 +525,23 @@ See `defclass' for more information." (and (eieio-object-p obj) (object-of-class-p obj ,cname)))) + ;; Create a handy list of the class test too + (let ((csym (intern (concat (symbol-name cname) "-list-p")))) + (fset csym + `(lambda (obj) + ,(format + "Test OBJ to see if it a list of objects which are a child of type %s" + cname) + (when (listp obj) + (let ((ans t)) ;; nil is valid + ;; Loop over all the elements of the input list, test + ;; each to make sure it is a child of the desired object class. + (while (and obj ans) + (setq ans (and (eieio-object-p (car obj)) + (object-of-class-p (car obj) ,cname))) + (setq obj (cdr obj))) + ans))))) + ;; When using typep, (typep OBJ 'myclass) returns t for objects which ;; are subclasses of myclass. For our predicates, however, it is ;; important for EIEIO to be backwards compatible, where @@ -556,8 +555,8 @@ See `defclass' for more information." (put cname 'cl-deftype-handler (list 'lambda () `(list 'satisfies (quote ,csym))))) - ;; before adding new slots, lets add all the methods and classes - ;; in from the parent class + ;; Before adding new slots, let's add all the methods and classes + ;; in from the parent class. (eieio-copy-parents-into-subclass newc superclasses) ;; Store the new class vector definition into the symbol. We need to @@ -655,58 +654,66 @@ See `defclass' for more information." ;; We need to id the group, and store them in a group list attribute. (mapc (lambda (cg) (add-to-list 'groups cg)) customg) - ;; anyone can have an accessor function. This creates a function + ;; Anyone can have an accessor function. This creates a function ;; of the specified name, and also performs a `defsetf' if applicable - ;; so that users can `setf' the space returned by this function + ;; so that users can `setf' the space returned by this function. (if acces (progn - (eieio-defmethod acces - (list (if (eq alloc :class) :static :primary) - (list (list 'this cname)) - (format + (eieio--defmethod + acces (if (eq alloc :class) :static :primary) cname + `(lambda (this) + ,(format "Retrieves the slot `%s' from an object of class `%s'" name cname) - (list 'if (list 'slot-boundp 'this (list 'quote name)) - (list 'eieio-oref 'this (list 'quote name)) + (if (slot-boundp this ',name) + (eieio-oref this ',name) ;; Else - Some error? nil? nil))) - ;; Provide a setf method. It would be cleaner to use - ;; defsetf, but that would require CL at runtime. - (put acces 'setf-method - `(lambda (widget) - (let* ((--widget-sym-- (make-symbol "--widget--")) - (--store-sym-- (make-symbol "--store--"))) - (list - (list --widget-sym--) - (list widget) - (list --store-sym--) - (list 'eieio-oset --widget-sym-- '',name --store-sym--) - (list 'getfoo --widget-sym--))))))) + (if (fboundp 'gv-define-setter) + ;; FIXME: We should move more of eieio-defclass into the + ;; defclass macro so we don't have to use `eval' and require + ;; `gv' at run-time. + (eval `(gv-define-setter ,acces (eieio--store eieio--object) + (list 'eieio-oset eieio--object '',name + eieio--store))) + ;; Provide a setf method. It would be cleaner to use + ;; defsetf, but that would require CL at runtime. + (put acces 'setf-method + `(lambda (widget) + (let* ((--widget-sym-- (make-symbol "--widget--")) + (--store-sym-- (make-symbol "--store--"))) + (list + (list --widget-sym--) + (list widget) + (list --store-sym--) + (list 'eieio-oset --widget-sym-- '',name + --store-sym--) + (list 'getfoo --widget-sym--)))))))) ;; If a writer is defined, then create a generic method of that ;; name whose purpose is to set the value of the slot. (if writer - (progn - (eieio-defmethod writer - (list (list (list 'this cname) 'value) - (format "Set the slot `%s' of an object of class `%s'" + (eieio--defmethod + writer nil cname + `(lambda (this value) + ,(format "Set the slot `%s' of an object of class `%s'" name cname) - `(setf (slot-value this ',name) value))) - )) + (setf (slot-value this ',name) value)))) ;; If a reader is defined, then create a generic method ;; of that name whose purpose is to access this slot value. (if reader - (progn - (eieio-defmethod reader - (list (list (list 'this cname)) - (format "Access the slot `%s' from object of class `%s'" + (eieio--defmethod + reader nil cname + `(lambda (this) + ,(format "Access the slot `%s' from object of class `%s'" name cname) - `(slot-value this ',name))))) + (slot-value this ',name)))) ) (setq slots (cdr slots))) - ;; Now that everything has been loaded up, all our lists are backwards! Fix that up now. + ;; Now that everything has been loaded up, all our lists are backwards! + ;; Fix that up now. (aset newc class-public-a (nreverse (aref newc class-public-a))) (aset newc class-public-d (nreverse (aref newc class-public-d))) (aset newc class-public-doc (nreverse (aref newc class-public-doc))) @@ -777,6 +784,16 @@ See `defclass' for more information." (put cname 'variable-documentation (class-option-assoc options :documentation)) + ;; Save the file location where this class is defined. + (let ((fname (if load-in-progress + load-file-name + buffer-file-name)) + loc) + (when fname + (when (string-match "\\.elc$" fname) + (setq fname (substring fname 0 (1- (length fname))))) + (put cname 'class-location fname))) + ;; We have a list of custom groups. Store them into the options. (let ((g (class-option-assoc options :custom-groups))) (mapc (lambda (cg) (add-to-list 'g cg)) groups) @@ -830,7 +847,7 @@ if default value is nil." ;; Make sure we duplicate those items that are sequences. (condition-case nil (if (sequencep d) (setq d (copy-sequence d))) - ;; This copy can fail on a cons cell with a non-cons in the cdr. Lets skip it if it doesn't work. + ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work. (error nil)) (if (sequencep type) (setq type (copy-sequence type))) (if (sequencep cust) (setq cust (copy-sequence cust))) @@ -962,7 +979,7 @@ if default value is nil." (progn (eieio-perform-slot-validation-for-default a type value skipnil) ;; Here we have found a :class version of a slot. This - ;; requires a very different aproach. + ;; requires a very different approach. (aset newc class-class-allocation-a (cons a (aref newc class-class-allocation-a))) (aset newc class-class-allocation-doc (cons doc (aref newc class-class-allocation-doc))) (aset newc class-class-allocation-type (cons type (aref newc class-class-allocation-type))) @@ -996,7 +1013,7 @@ if default value is nil." ;; EML - Note: the only reason to override a class bound slot ;; is to change the default, so allow unbound in. - ;; If we have a repeat, only update the vlaue... + ;; If we have a repeat, only update the value... (eieio-perform-slot-validation-for-default a tp value skipnil) (setcar dp value)) @@ -1144,6 +1161,17 @@ a string." ;;; CLOS methods and generics ;; + +(put 'eieio--defalias 'byte-hunk-handler + #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) +(defun eieio--defalias (name body) + "Like `defalias', but with less side-effects. +More specifically, it has no side-effects at all when the new function +definition is the same (`eq') as the old one." + (unless (and (fboundp name) + (eq (symbol-function name) body)) + (defalias name body))) + (defmacro defgeneric (method args &optional doc-string) "Create a generic function METHOD. DOC-STRING is the base documentation for this class. A generic @@ -1152,7 +1180,21 @@ is appropriate to use. Uses `defmethod' to create methods, and calls `defgeneric' for you. With this implementation the ARGS are currently ignored. You can use `defgeneric' to apply specialized top level documentation to a method." - `(eieio-defgeneric (quote ,method) ,doc-string)) + `(eieio--defalias ',method + (eieio--defgeneric-init-form ',method ,doc-string))) + +(defun eieio--defgeneric-init-form (method doc-string) + "Form to use for the initial definition of a generic." + (cond + ((or (not (fboundp method)) + (eq 'autoload (car-safe (symbol-function method)))) + ;; Make sure the method tables are installed. + (eieiomt-install method) + ;; Construct the actual body of this function. + (eieio-defgeneric-form method doc-string)) + ((generic-p method) (symbol-function method)) ;Leave it as-is. + (t (error "You cannot create a generic/method over an existing symbol: %s" + method)))) (defun eieio-defgeneric-form (method doc-string) "The lambda form that would be used as the function defined on METHOD. @@ -1193,10 +1235,8 @@ IMPL is the symbol holding the method implementation." ;; is faster to execute this for not byte-compiled. ie, install this, ;; then measure calls going through here. I wonder why. (require 'bytecomp) - (let ((byte-compile-free-references nil) - (byte-compile-warnings nil) - ) - (byte-compile-lambda + (let ((byte-compile-warnings nil)) + (byte-compile `(lambda (&rest local-args) ,doc-string ;; This is a cool cheat. Usually we need to look up in the @@ -1206,32 +1246,32 @@ IMPL is the symbol holding the method implementation." ;; of that one implementation, then clearly, there is no method def. (if (not (eieio-object-p (car local-args))) ;; Not an object. Just signal. - (signal 'no-method-definition (list ,(list 'quote method) local-args)) + (signal 'no-method-definition + (list ',method local-args)) ;; We do have an object. Make sure it is the right type. (if ,(if (eq class eieio-default-superclass) - nil ; default superclass means just an obj. Already asked. + nil ; default superclass means just an obj. Already asked. `(not (child-of-class-p (aref (car local-args) object-class) - ,(list 'quote class))) - ) + ',class))) ;; If not the right kind of object, call no applicable (apply 'no-applicable-method (car local-args) - ,(list 'quote method) local-args) + ',method local-args) ;; It is ok, do the call. ;; Fill in inter-call variables then evaluate the method. - (let ((scoped-class ,(list 'quote class)) + (let ((scoped-class ',class) (eieio-generic-call-next-method-list nil) (eieio-generic-call-key method-primary) - (eieio-generic-call-methodname ,(list 'quote method)) + (eieio-generic-call-methodname ',method) (eieio-generic-call-arglst local-args) ) - (apply ,(list 'quote impl) local-args) + ,(if (< emacs-major-version 24) + `(apply ,(list 'quote impl) local-args) + `(apply #',impl local-args)) ;(,impl local-args) - )))) - ) - )) + ))))))) (defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) "Setup METHOD to call the generic form." @@ -1245,26 +1285,6 @@ IMPL is the symbol holding the method implementation." (cdr entry) )))) -(defun eieio-defgeneric (method doc-string) - "Engine part to `defgeneric' macro defining METHOD with DOC-STRING." - (if (and (fboundp method) (not (generic-p method)) - (or (byte-code-function-p (symbol-function method)) - (not (eq 'autoload (car (symbol-function method))))) - ) - (error "You cannot create a generic/method over an existing symbol: %s" - method)) - ;; Don't do this over and over. - (unless (fboundp 'method) - ;; This defun tells emacs where the first definition of this - ;; method is defined. - `(defun ,method nil) - ;; Make sure the method tables are installed. - (eieiomt-install method) - ;; Apply the actual body of this function. - (fset method (eieio-defgeneric-form method doc-string)) - ;; Return the method - 'method)) - (defun eieio-unbind-method-implementations (method) "Make the generic method METHOD have no implementations. It will leave the original generic function in place, @@ -1297,66 +1317,59 @@ Summary: ((typearg class-name) arg2 &optional opt &rest rest) \"doc-string\" body)" - `(eieio-defmethod (quote ,method) (quote ,args))) - -(defun eieio-defmethod (method args) + (let* ((key (if (keywordp (car args)) (pop args))) + (params (car args)) + (arg1 (car params)) + (fargs (if (consp arg1) + (cons (car arg1) (cdr params)) + params)) + (class (if (consp arg1) (nth 1 arg1))) + (code `(lambda ,fargs ,@(cdr args)))) + `(progn + ;; Make sure there is a generic and the byte-compiler sees it. + (defgeneric ,method ,args + ,(or (documentation code) + (format "Generically created method `%s'." method))) + (eieio--defmethod ',method ',key ',class #',code)))) + +(defun eieio--defmethod (method kind argclass code) "Work part of the `defmethod' macro defining METHOD with ARGS." - (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) - ;; find optional keys - (setq key - (cond ((or (eq ':BEFORE (car args)) - (eq ':before (car args))) - (setq args (cdr args)) - method-before) - ((or (eq ':AFTER (car args)) - (eq ':after (car args))) - (setq args (cdr args)) - method-after) - ((or (eq ':PRIMARY (car args)) - (eq ':primary (car args))) - (setq args (cdr args)) - method-primary) - ((or (eq ':STATIC (car args)) - (eq ':static (car args))) - (setq args (cdr args)) - method-static) - ;; Primary key - (t method-primary))) - ;; get body, and fix contents of args to be the arguments of the fn. - (setq body (cdr args) - args (car args)) - (setq loopa args) - ;; Create a fixed version of the arguments - (while loopa - (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) - argfix)) - (setq loopa (cdr loopa))) - ;; make sure there is a generic - (eieio-defgeneric - method - (if (stringp (car body)) - (car body) (format "Generically created method `%s'." method))) + (let ((key + ;; find optional keys + (cond ((or (eq ':BEFORE kind) + (eq ':before kind)) + method-before) + ((or (eq ':AFTER kind) + (eq ':after kind)) + method-after) + ((or (eq ':PRIMARY kind) + (eq ':primary kind)) + method-primary) + ((or (eq ':STATIC kind) + (eq ':static kind)) + method-static) + ;; Primary key + (t method-primary)))) + ;; Make sure there is a generic (when called from defclass). + (eieio--defalias + method (eieio--defgeneric-init-form + method (or (documentation code) + (format "Generically created method `%s'." method)))) ;; create symbol for property to bind to. If the first arg is of ;; the form (varname vartype) and `vartype' is a class, then ;; that class will be the type symbol. If not, then it will fall ;; under the type `primary' which is a non-specific calling of the ;; function. - (setq firstarg (car args)) - (if (listp firstarg) - (progn - (setq argclass (nth 1 firstarg)) - (if (not (class-p argclass)) - (error "Unknown class type %s in method parameters" - (nth 1 firstarg)))) + (if argclass + (if (not (class-p argclass)) + (error "Unknown class type %s in method parameters" + argclass)) (if (= key -1) (signal 'wrong-type-argument (list :static 'non-class-arg))) ;; generics are higher (setq key (eieio-specialized-key-to-generic-key key))) ;; Put this lambda into the symbol so we can find it - (if (byte-code-function-p (car-safe body)) - (eieiomt-add method (car-safe body) key argclass) - (eieiomt-add method (append (list 'lambda (reverse argfix)) body) - key argclass)) + (eieiomt-add method code key argclass) ) (when eieio-optimize-primary-methods-flag @@ -1480,7 +1493,7 @@ created by the :initarg tag." (c (eieio-slot-name-index class obj slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. - ;; Lets check that info out. + ;; Let's check that info out. (if (setq c (eieio-class-slot-name-index class slot)) ;; Oref that slot. (aref (aref (class-v class) class-class-allocation-values) c) @@ -1513,7 +1526,7 @@ Fills in OBJ's SLOT with its default value." (c (eieio-slot-name-index cl obj slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. - ;; Lets check that info out. + ;; Let's check that info out. (if (setq c (eieio-class-slot-name-index cl slot)) ;; Oref that slot. @@ -1543,71 +1556,6 @@ Fills in OBJ's SLOT with its default value." ;; return it verbatim (t val))) -;;; Object Set macros -;; -(defmacro oset (obj slot value) - "Set the value in OBJ for slot SLOT to VALUE. -SLOT is the slot name as specified in `defclass' or the tag created -with in the :initarg slot. VALUE can be any Lisp object." - `(eieio-oset ,obj (quote ,slot) ,value)) - -(defun eieio-oset (obj slot value) - "Do the work for the macro `oset'. -Fills in OBJ's SLOT with VALUE." - (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) - (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) - (let ((c (eieio-slot-name-index (object-class-fast obj) obj slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Lets check that info out. - (if (setq c - (eieio-class-slot-name-index (aref obj object-class) slot)) - ;; Oset that slot. - (progn - (eieio-validate-class-slot-value (object-class-fast obj) c value slot) - (aset (aref (class-v (aref obj object-class)) - class-class-allocation-values) - c value)) - ;; See oref for comment on `slot-missing' - (slot-missing obj slot 'oset value) - ;;(signal 'invalid-slot-name (list (object-name obj) slot)) - ) - (eieio-validate-slot-value (object-class-fast obj) c value slot) - (aset obj c value)))) - -(defmacro oset-default (class slot value) - "Set the default slot in CLASS for SLOT to VALUE. -The default value is usually set with the :initform tag during class -creation. This allows users to change the default behavior of classes -after they are created." - `(eieio-oset-default ,class (quote ,slot) ,value)) - -(defun eieio-oset-default (class slot value) - "Do the work for the macro `oset-default'. -Fills in the default value in CLASS' in SLOT with VALUE." - (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) - (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) - (let* ((scoped-class class) - (c (eieio-slot-name-index class nil slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Lets check that info out. - (if (setq c (eieio-class-slot-name-index class slot)) - (progn - ;; Oref that slot. - (eieio-validate-class-slot-value class c value slot) - (aset (aref (class-v class) class-class-allocation-values) c - value)) - (signal 'invalid-slot-name (list (class-name class) slot))) - (eieio-validate-slot-value class c value slot) - ;; Set this into the storage for defaults. - (setcar (nthcdr (- c 3) (aref (class-v class) class-public-d)) - value) - ;; Take the value, and put it into our cache object. - (eieio-oset (aref (class-v class) class-default-object-cache) - slot value) - ))) - ;;; Handy CLOS macros ;; (defmacro with-slots (spec-list object &rest body) @@ -1629,6 +1577,7 @@ SPEC-LIST is of a form similar to `let'. For example: Where each VAR is the local variable given to the associated SLOT. A slot specified without a variable name is given a variable name of the same name as the slot." + (declare (indent 2)) ;; Transform the spec-list into a symbol-macrolet spec-list. (let ((mappings (mapcar (lambda (entry) (let ((var (if (listp entry) (car entry) entry)) @@ -1637,8 +1586,6 @@ variable name of the same name as the slot." spec-list))) (append (list 'symbol-macrolet mappings) body))) -(put 'with-slots 'lisp-indent-function 2) - ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. @@ -1859,6 +1806,71 @@ method invocation orders of the involved classes." (setq ia (cdr ia))) f)) +;;; Object Set macros +;; +(defmacro oset (obj slot value) + "Set the value in OBJ for slot SLOT to VALUE. +SLOT is the slot name as specified in `defclass' or the tag created +with in the :initarg slot. VALUE can be any Lisp object." + `(eieio-oset ,obj (quote ,slot) ,value)) + +(defun eieio-oset (obj slot value) + "Do the work for the macro `oset'. +Fills in OBJ's SLOT with VALUE." + (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) + (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) + (let ((c (eieio-slot-name-index (object-class-fast obj) obj slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c + (eieio-class-slot-name-index (aref obj object-class) slot)) + ;; Oset that slot. + (progn + (eieio-validate-class-slot-value (object-class-fast obj) c value slot) + (aset (aref (class-v (aref obj object-class)) + class-class-allocation-values) + c value)) + ;; See oref for comment on `slot-missing' + (slot-missing obj slot 'oset value) + ;;(signal 'invalid-slot-name (list (object-name obj) slot)) + ) + (eieio-validate-slot-value (object-class-fast obj) c value slot) + (aset obj c value)))) + +(defmacro oset-default (class slot value) + "Set the default slot in CLASS for SLOT to VALUE. +The default value is usually set with the :initform tag during class +creation. This allows users to change the default behavior of classes +after they are created." + `(eieio-oset-default ,class (quote ,slot) ,value)) + +(defun eieio-oset-default (class slot value) + "Do the work for the macro `oset-default'. +Fills in the default value in CLASS' in SLOT with VALUE." + (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) + (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot))) + (let* ((scoped-class class) + (c (eieio-slot-name-index class nil slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c (eieio-class-slot-name-index class slot)) + (progn + ;; Oref that slot. + (eieio-validate-class-slot-value class c value slot) + (aset (aref (class-v class) class-class-allocation-values) c + value)) + (signal 'invalid-slot-name (list (class-name class) slot))) + (eieio-validate-slot-value class c value slot) + ;; Set this into the storage for defaults. + (setcar (nthcdr (- c 3) (aref (class-v class) class-public-d)) + value) + ;; Take the value, and put it into our cache object. + (eieio-oset (aref (class-v class) class-default-object-cache) + slot value) + ))) + ;;; CLOS queries into classes and slots ;; (defun slot-boundp (object slot) @@ -1869,11 +1881,11 @@ OBJECT can be an instance or a class." ;; Skip typechecking while retrieving this value. (let ((eieio-skip-typecheck t)) ;; Return nil if the magic symbol is in there. - (if (eieio-object-p object) - (if (eq (eieio-oref object slot) eieio-unbound) nil t) - (if (class-p object) - (if (eq (eieio-oref-default object slot) eieio-unbound) nil t) - (signal 'wrong-type-argument (list 'eieio-object-p object)))))) + (not (eq (cond + ((eieio-object-p object) (eieio-oref object slot)) + ((class-p object) (eieio-oref-default object slot)) + (t (signal 'wrong-type-argument (list 'eieio-object-p object)))) + eieio-unbound)))) (defun slot-makeunbound (object slot) "In OBJECT, make SLOT unbound." @@ -2011,13 +2023,13 @@ reverse-lookup that name, and recurse with the associated slot value." ((not (get fsym 'protection)) (+ 3 fsi)) ((and (eq (get fsym 'protection) 'protected) - scoped-class + (bound-and-true-p scoped-class) (or (child-of-class-p class scoped-class) (and (eieio-object-p obj) (child-of-class-p class (object-class obj))))) (+ 3 fsi)) ((and (eq (get fsym 'protection) 'private) - (or (and scoped-class + (or (and (bound-and-true-p scoped-class) (eieio-slot-originating-class-p scoped-class slot)) eieio-initializing-object)) (+ 3 fsi)) @@ -2054,8 +2066,10 @@ Keys are a number representing :before, :primary, and :after methods.") During executions, the list is first generated, then as each next method is called, the next method is popped off the stack.") -(defvar eieio-pre-method-execution-hooks nil - "*Hooks run just before a method is executed. +(define-obsolete-variable-alias 'eieio-pre-method-execution-hooks + 'eieio-pre-method-execution-functions "24.3") +(defvar eieio-pre-method-execution-functions nil + "Abnormal hook run just before an EIEIO method is executed. The hook function must accept one argument, the list of forms about to be executed.") @@ -2160,7 +2174,7 @@ This should only be called from a generic function." (eieiomt-method-list method method-primary nil))) ) - (run-hook-with-args 'eieio-pre-method-execution-hooks + (run-hook-with-args 'eieio-pre-method-execution-functions primarymethodlist) ;; Now loop through all occurrences forms which we must execute @@ -2265,7 +2279,7 @@ for this common case to improve performance." ;; Do the regular implementation here. - (run-hook-with-args 'eieio-pre-method-execution-hooks + (run-hook-with-args 'eieio-pre-method-execution-functions lambdas) (setq lastval (apply (car lambdas) newargs)) @@ -2322,7 +2336,7 @@ If REPLACEMENT-ARGS is non-nil, then use them instead of arguments passed in at the top level. Use `next-method-p' to find out if there is a next method to call." - (if (not scoped-class) + (if (not (bound-and-true-p scoped-class)) (error "`call-next-method' not called within a class specific method")) (if (and (/= eieio-generic-call-key method-primary) (/= eieio-generic-call-key method-static)) @@ -2406,6 +2420,18 @@ CLASS is the class this method is associated with." (if (< key method-num-lists) (let ((nsym (intern (symbol-name class) (aref emto key)))) (fset nsym method))) + ;; Save the defmethod file location in a symbol property. + (let ((fname (if load-in-progress + load-file-name + buffer-file-name)) + loc) + (when fname + (when (string-match "\\.elc$" fname) + (setq fname (substring fname 0 (1- (length fname))))) + (setq loc (get method-name 'method-locations)) + (add-to-list 'loc + (list class fname)) + (put method-name 'method-locations loc))) ;; Now optimize the entire obarray (if (< key method-num-lists) (let ((eieiomt-optimizing-obarray (aref emto key))) @@ -2554,8 +2580,13 @@ This is usually a symbol that starts with `:'." ;;; Here are some CLOS items that need the CL package ;; -(defsetf slot-value (obj slot) (store) (list 'eieio-oset obj slot store)) -(defsetf eieio-oref (obj slot) (store) (list 'eieio-oset obj slot store)) +(defsetf eieio-oref eieio-oset) + +(if (eval-when-compile (fboundp 'gv-define-expander)) + ;; Not needed for Emacs>=24.3 since gv.el's setf expands macros and + ;; follows aliases. + nil +(defsetf slot-value eieio-oset) ;; The below setf method was written by Arnd Kohrs <kohrs@acm.org> (define-setf-method oref (obj slot) @@ -2569,12 +2600,12 @@ This is usually a symbol that starts with `:'." (list store-temp) (list 'set-slot-value obj-temp slot-temp store-temp) - (list 'slot-value obj-temp slot-temp))))) + (list 'slot-value obj-temp slot-temp)))))) ;;; ;; We want all objects created by EIEIO to have some default set of -;; behaviours so we can create object utilities, and allow various +;; behaviors so we can create object utilities, and allow various ;; types of error checking. To do this, create the default EIEIO ;; class, and when no parent class is specified, use this as the ;; default. (But don't store it in the other classes as the default, @@ -2721,7 +2752,7 @@ This method signals `no-next-method' by default. Override this method to not throw an error, and its return value becomes the return value of `call-next-method'." (signal 'no-next-method (list (object-name object) args)) -) + ) (defgeneric clone (obj &rest params) "Make a copy of OBJ, and then supply PARAMS. @@ -2805,9 +2836,9 @@ this object." (princ (make-string (* eieio-print-depth 2) ? )) (princ "(") (princ (symbol-name (class-constructor (object-class this)))) - (princ " \"") - (princ (object-name-string this)) - (princ "\"\n") + (princ " ") + (prin1 (object-name-string this)) + (princ "\n") ;; Loop over all the public slots (let ((publa (aref cv class-public-a)) (publd (aref cv class-public-d)) @@ -2874,7 +2905,106 @@ of `eq'." ) - +;;; Obsolete backward compatibility functions. +;; Needed to run byte-code compiled with the EIEIO of Emacs-23. + +(defun eieio-defmethod (method args) + "Obsolete work part of an old version of the `defmethod' macro." + (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) + ;; find optional keys + (setq key + (cond ((or (eq ':BEFORE (car args)) + (eq ':before (car args))) + (setq args (cdr args)) + method-before) + ((or (eq ':AFTER (car args)) + (eq ':after (car args))) + (setq args (cdr args)) + method-after) + ((or (eq ':PRIMARY (car args)) + (eq ':primary (car args))) + (setq args (cdr args)) + method-primary) + ((or (eq ':STATIC (car args)) + (eq ':static (car args))) + (setq args (cdr args)) + method-static) + ;; Primary key + (t method-primary))) + ;; get body, and fix contents of args to be the arguments of the fn. + (setq body (cdr args) + args (car args)) + (setq loopa args) + ;; Create a fixed version of the arguments + (while loopa + (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) + argfix)) + (setq loopa (cdr loopa))) + ;; make sure there is a generic + (eieio-defgeneric + method + (if (stringp (car body)) + (car body) (format "Generically created method `%s'." method))) + ;; create symbol for property to bind to. If the first arg is of + ;; the form (varname vartype) and `vartype' is a class, then + ;; that class will be the type symbol. If not, then it will fall + ;; under the type `primary' which is a non-specific calling of the + ;; function. + (setq firstarg (car args)) + (if (listp firstarg) + (progn + (setq argclass (nth 1 firstarg)) + (if (not (class-p argclass)) + (error "Unknown class type %s in method parameters" + (nth 1 firstarg)))) + (if (= key -1) + (signal 'wrong-type-argument (list :static 'non-class-arg))) + ;; generics are higher + (setq key (eieio-specialized-key-to-generic-key key))) + ;; Put this lambda into the symbol so we can find it + (if (byte-code-function-p (car-safe body)) + (eieiomt-add method (car-safe body) key argclass) + (eieiomt-add method (append (list 'lambda (reverse argfix)) body) + key argclass)) + ) + + (when eieio-optimize-primary-methods-flag + ;; Optimizing step: + ;; + ;; If this method, after this setup, only has primary methods, then + ;; we can setup the generic that way. + (if (generic-primary-only-p method) + ;; If there is only one primary method, then we can go one more + ;; optimization step. + (if (generic-primary-only-one-p method) + (eieio-defgeneric-reset-generic-form-primary-only-one method) + (eieio-defgeneric-reset-generic-form-primary-only method)) + (eieio-defgeneric-reset-generic-form method))) + + method) +(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1") + +(defun eieio-defgeneric (method doc-string) + "Obsolete work part of an old version of the `defgeneric' macro." + (if (and (fboundp method) (not (generic-p method)) + (or (byte-code-function-p (symbol-function method)) + (not (eq 'autoload (car (symbol-function method))))) + ) + (error "You cannot create a generic/method over an existing symbol: %s" + method)) + ;; Don't do this over and over. + (unless (fboundp 'method) + ;; This defun tells emacs where the first definition of this + ;; method is defined. + `(defun ,method nil) + ;; Make sure the method tables are installed. + (eieiomt-install method) + ;; Apply the actual body of this function. + (fset method (eieio-defgeneric-form method doc-string)) + ;; Return the method + 'method)) +(make-obsolete 'eieio-defgeneric nil "24.1") + ;;; Interfacing with edebug ;; (defun eieio-edebug-prin1-to-string (object &optional noescape) @@ -2919,43 +3049,67 @@ Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." ) ) -;;; Interfacing with imenu in emacs lisp mode -;; (Only if the expression is defined) -;; -(if (eval-when-compile (boundp 'list-imenu-generic-expression)) -(progn - -(defun eieio-update-lisp-imenu-expression () - "Examine `lisp-imenu-generic-expression' and modify it to find `defmethod'." - (let ((exp lisp-imenu-generic-expression)) - (while exp - ;; it's of the form '( ( title expr indx ) ... ) - (let* ((subcar (cdr (car exp))) - (substr (car subcar))) - (if (and (not (string-match "|method\\\\" substr)) - (string-match "|advice\\\\" substr)) - (setcar subcar - (replace-match "|advice\\|method\\" t t substr 0)))) - (setq exp (cdr exp))))) - -(eieio-update-lisp-imenu-expression) - -)) - ;;; Autoloading some external symbols, and hooking into the help system ;; -(autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "For buffers thrown into help mode, augment for EIEIO.") -(autoload 'eieio-browse "eieio-opt" "Create an object browser window." t) -(autoload 'eieio-describe-class "eieio-opt" "Describe CLASS defined by a string or symbol" t) -(autoload 'eieio-describe-constructor "eieio-opt" "Describe the constructor function FCN." t) -(autoload 'describe-class "eieio-opt" "Describe CLASS defined by a string or symbol." t) -(autoload 'eieio-describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol." t) -(autoload 'describe-generic "eieio-opt" "Describe GENERIC defined by a string or symbol." t) + +;;; Start of automatically extracted autoloads. + +;;;### (autoloads (customize-object) "eieio-custom" "eieio-custom.el" +;;;;;; "928623502e8bf40454822355388542b5") +;;; Generated autoloads from eieio-custom.el + +(autoload 'customize-object "eieio-custom" "\ +Customize OBJ in a custom buffer. +Optional argument GROUP is the sub-group of slots to display. + +\(fn OBJ &optional GROUP)" nil nil) + +;;;*** + +;;;### (autoloads (eieio-help-mode-augmentation-maybee eieio-describe-generic +;;;;;; eieio-describe-constructor eieio-describe-class eieio-browse) +;;;;;; "eieio-opt" "eieio-opt.el" "d808328f9c0156ecbd412d77ba8c569e") +;;; Generated autoloads from eieio-opt.el + +(autoload 'eieio-browse "eieio-opt" "\ +Create an object browser window to show all objects. +If optional ROOT-CLASS, then start with that, otherwise start with +variable `eieio-default-superclass'. -(autoload 'customize-object "eieio-custom" "Create a custom buffer editing OBJ.") +\(fn &optional ROOT-CLASS)" t nil) +(defalias 'describe-class 'eieio-describe-class) + +(autoload 'eieio-describe-class "eieio-opt" "\ +Describe a CLASS defined by a string or symbol. +If CLASS is actually an object, then also display current values of that object. +Optional HEADERFCN should be called to insert a few bits of info first. + +\(fn CLASS &optional HEADERFCN)" t nil) + +(autoload 'eieio-describe-constructor "eieio-opt" "\ +Describe the constructor function FCN. +Uses `eieio-describe-class' to describe the class being constructed. + +\(fn FCN)" t nil) +(defalias 'describe-generic 'eieio-describe-generic) + +(autoload 'eieio-describe-generic "eieio-opt" "\ +Describe the generic function GENERIC. +Also extracts information about all methods specific to this generic. + +\(fn GENERIC)" t nil) + +(autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "\ +For buffers thrown into help mode, augment for EIEIO. +Arguments UNUSED are not used. + +\(fn &rest UNUSED)" nil nil) + +;;;*** + +;;; End of automatically extracted autoloads. (provide 'eieio) -;; arch-tag: c1aeab9c-2938-41a3-842b-1a38bd26e9f2 ;;; eieio ends here diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 08f04a43698..0f01857381c 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -1,7 +1,6 @@ ;;; eldoc.el --- show function arglist or variable docstring in echo area -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1996-2013 Free Software Foundation, Inc. ;; Author: Noah Friedman <friedman@splode.com> ;; Maintainer: friedman@splode.com @@ -150,14 +149,17 @@ This is used to determine if `eldoc-idle-delay' is changed by the user.") ;;;###autoload (define-minor-mode eldoc-mode - "Toggle ElDoc mode on or off. -In ElDoc mode, the echo area displays information about a -function or variable in the text where point is. If point is -on a documented variable, it displays the first line of that -variable's doc string. Otherwise it displays the argument list -of the function called in the expression point is on. - -With prefix ARG, turn ElDoc mode on if and only if ARG is positive." + "Toggle echo area display of Lisp objects at point (ElDoc mode). +With a prefix argument ARG, enable ElDoc mode if ARG is positive, +and disable it otherwise. If called from Lisp, enable ElDoc mode +if ARG is omitted or nil. + +ElDoc mode is a buffer-local minor mode. When enabled, the echo +area displays information about a function or variable in the +text where point is. If point is on a documented variable, it +displays the first line of that variable's doc string. Otherwise +it displays the argument list of the function called in the +expression point is on." :group 'eldoc :lighter eldoc-minor-mode-string (setq eldoc-last-message nil) (if eldoc-mode @@ -432,7 +434,7 @@ In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." nil (list (eldoc-current-symbol) argument-index))))) -;; Move to the beginnig of current sexp. Return the number of nested +;; Move to the beginning of current sexp. Return the number of nested ;; sexp the point was over or after. (defun eldoc-beginning-of-sexp () (let ((parse-sexp-ignore-comments t) @@ -530,15 +532,14 @@ The words \"&rest\", \"&optional\" are returned unchanged." ;; Prime the command list. (eldoc-add-command-completions - "backward-" "beginning-of-" "move-beginning-of-" "delete-other-windows" - "delete-window" "handle-select-window" - "end-of-" "move-end-of-" "exchange-point-and-mark" "forward-" - "indent-for-tab-command" "goto-" "mark-page" "mark-paragraph" - "mouse-set-point" "move-" "pop-global-mark" "next-" "other-window" - "previous-" "recenter" "scroll-" "self-insert-command" - "split-window-" "up-list" "down-list") + "backward-" "beginning-of-" "delete-other-windows" "delete-window" + "down-list" "end-of-" "exchange-point-and-mark" "forward-" "goto-" + "handle-select-window" "indent-for-tab-command" "left-" "mark-page" + "mark-paragraph" "mouse-set-point" "move-" "move-beginning-of-" + "move-end-of-" "next-" "other-window" "pop-global-mark" "previous-" + "recenter" "right-" "scroll-" "self-insert-command" "split-window-" + "up-list") (provide 'eldoc) -;; arch-tag: c9a58f9d-2055-46c1-9b82-7248b71a8375 ;;; eldoc.el ends here diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index bda9269ae9f..7998f732f06 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -1,7 +1,6 @@ ;;; elint.el --- Lint Emacs Lisp -;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1997, 2001-2013 Free Software Foundation, Inc. ;; Author: Peter Liljenberg <petli@lysator.liu.se> ;; Created: May 1997 @@ -47,6 +46,8 @@ ;;; Code: +(require 'help-fns) + (defgroup elint nil "Linting for Emacs Lisp." :prefix "elint-" @@ -123,7 +124,6 @@ are as follows, and suppress messages about the indicated features: ;; FIXME I don't see why they shouldn't just get doc-strings. '(vc-mode local-write-file-hooks activate-menubar-hook buffer-name-history coding-system-history extended-command-history - kbd-macro-termination-hook read-expression-history yes-or-no-p-history) "Standard variables, excluding `elint-builtin-variables'. These are variables that we cannot detect automatically for some reason.") @@ -298,7 +298,7 @@ If necessary, this first calls `elint-initialize'." (elint-display-log) (elint-set-mode-line t) (mapc 'elint-top-form (elint-update-env)) - ;; Tell the user we're finished. This is terribly klugy: we set + ;; Tell the user we're finished. This is terribly kludgy: we set ;; elint-top-form-logged so elint-log-message doesn't print the ;; ** top form ** header... (elint-set-mode-line) @@ -337,7 +337,7 @@ Will be local in linted buffers.") Is measured in buffer-modified-ticks and is local in linted buffers.") ;; This is a minor optimization. It is local to every buffer, and so -;; does not prevent recursive requirs. It does not list the requires +;; does not prevent recursive requires. It does not list the requires ;; of requires. (defvar elint-features nil "List of all libraries this buffer has required, or that have been provided.") @@ -359,6 +359,8 @@ Returns the forms." (set (make-local-variable 'elint-buffer-env) (elint-init-env elint-buffer-forms)) (if elint-preloaded-env + ;; FIXME: This doesn't do anything! Should we setq the result to + ;; elint-buffer-env? (elint-env-add-env elint-preloaded-env elint-buffer-env)) (set (make-local-variable 'elint-last-env-time) (buffer-modified-tick)) elint-buffer-forms)) @@ -394,40 +396,41 @@ Return nil if there are no more forms, t otherwise." (parse-partial-sexp (point) (point-max) nil t) (not (eobp))) -(defvar env) ; from elint-init-env +(defvar elint-env) ; from elint-init-env (defun elint-init-form (form) - "Process FORM, adding to ENV if recognized." + "Process FORM, adding to ELINT-ENV if recognized." (cond ;; Eg nnmaildir seems to use [] as a form of comment syntax. ((not (listp form)) (elint-warning "Skipping non-list form `%s'" form)) ;; Add defined variable ((memq (car form) '(defvar defconst defcustom)) - (setq env (elint-env-add-var env (cadr form)))) + (setq elint-env (elint-env-add-var elint-env (cadr form)))) ;; Add function ((memq (car form) '(defun defsubst)) - (setq env (elint-env-add-func env (cadr form) (nth 2 form)))) + (setq elint-env (elint-env-add-func elint-env (cadr form) (nth 2 form)))) ;; FIXME needs a handler to say second arg is not a variable when we come ;; to scan the form. ((eq (car form) 'define-derived-mode) - (setq env (elint-env-add-func env (cadr form) ()) - env (elint-env-add-var env (cadr form)) - env (elint-env-add-var env (intern (format "%s-map" (cadr form)))))) + (setq elint-env (elint-env-add-func elint-env (cadr form) ()) + elint-env (elint-env-add-var elint-env (cadr form)) + elint-env (elint-env-add-var elint-env + (intern (format "%s-map" (cadr form)))))) ((eq (car form) 'define-minor-mode) - (setq env (elint-env-add-func env (cadr form) '(&optional arg)) + (setq elint-env (elint-env-add-func elint-env (cadr form) '(&optional arg)) ;; FIXME mode map? - env (elint-env-add-var env (cadr form)))) + elint-env (elint-env-add-var elint-env (cadr form)))) ((and (eq (car form) 'easy-menu-define) (cadr form)) - (setq env (elint-env-add-func env (cadr form) '(event)) - env (elint-env-add-var env (cadr form)))) + (setq elint-env (elint-env-add-func elint-env (cadr form) '(event)) + elint-env (elint-env-add-var elint-env (cadr form)))) ;; FIXME it would be nice to check the autoloads are correct. ((eq (car form) 'autoload) - (setq env (elint-env-add-func env (cadr (cadr form)) 'unknown))) + (setq elint-env (elint-env-add-func elint-env (cadr (cadr form)) 'unknown))) ((eq (car form) 'declare-function) - (setq env (elint-env-add-func - env (cadr form) + (setq elint-env (elint-env-add-func + elint-env (cadr form) (if (or (< (length form) 4) (eq (nth 3 form) t) (unless (stringp (nth 2 form)) @@ -440,14 +443,14 @@ Return nil if there are no more forms, t otherwise." ;; If the alias points to something already in the environment, ;; add the alias to the environment with the same arguments. ;; FIXME symbol-function, eg backquote.el? - (let ((def (elint-env-find-func env (cadr (nth 2 form))))) - (setq env (elint-env-add-func env (cadr (cadr form)) + (let ((def (elint-env-find-func elint-env (cadr (nth 2 form))))) + (setq elint-env (elint-env-add-func elint-env (cadr (cadr form)) (if def (cadr def) 'unknown))))) ;; Add macro, both as a macro and as a function ((eq (car form) 'defmacro) - (setq env (elint-env-add-macro env (cadr form) + (setq elint-env (elint-env-add-macro elint-env (cadr form) (cons 'lambda (cddr form))) - env (elint-env-add-func env (cadr form) (nth 2 form)))) + elint-env (elint-env-add-func elint-env (cadr form) (nth 2 form)))) ((and (eq (car form) 'put) (= 4 (length form)) (eq (car-safe (cadr form)) 'quote) @@ -465,18 +468,21 @@ Return nil if there are no more forms, t otherwise." (add-to-list 'elint-features name) ;; cl loads cl-macs in an opaque manner. ;; Since cl-macs requires cl, we can just process cl-macs. + ;; FIXME: AFAIK, `cl' now behaves properly and does not need any + ;; special treatment any more. Can someone who understands this + ;; code confirm? --Stef (and (eq name 'cl) (not elint-doing-cl) ;; We need cl if elint-form is to be able to expand cl macros. (require 'cl) (setq name 'cl-macs file nil elint-doing-cl t)) ; blech - (setq env (elint-add-required-env env name file)))))) - env) + (setq elint-env (elint-add-required-env elint-env name file)))))) + elint-env) (defun elint-init-env (forms) "Initialize the environment from FORMS." - (let ((env (elint-make-env)) + (let ((elint-env (elint-make-env)) form) (while forms (setq form (elint-top-form-form (car forms)) @@ -489,7 +495,7 @@ Return nil if there are no more forms, t otherwise." with-no-warnings)) (mapc 'elint-init-form (cdr form)) (elint-init-form form))) - env)) + elint-env)) (defun elint-add-required-env (env name file) "Augment ENV with the variables defined by feature NAME in FILE." @@ -709,14 +715,8 @@ Returns `unknown' if we couldn't find arguments." (defun elint-find-args-in-code (code) "Extract the arguments from CODE. CODE can be a lambda expression, a macro, or byte-compiled code." - (cond - ((byte-code-function-p code) - (aref code 0)) - ((and (listp code) (eq (car code) 'lambda)) - (car (cdr code))) - ((and (listp code) (eq (car code) 'macro)) - (elint-find-args-in-code (cdr code))) - (t 'unknown))) + (let ((args (help-function-arglist code))) + (if (listp args) args 'unknown))) ;;; ;;; Functions to check some special forms @@ -1099,7 +1099,7 @@ optional prefix argument REINIT is non-nil." ;; This includes all the built-in and dumped things with documentation. (defun elint-scan-doc-file () "Scan the DOC file for function and variables. -Marks the function wih their arguments, and returns a list of variables." +Marks the function with their arguments, and returns a list of variables." ;; Cribbed from help-fns.el. (let ((docbuf " *DOC*") vars sym args) @@ -1171,5 +1171,4 @@ If no documentation could be found args will be `unknown'." (provide 'elint) -;; arch-tag: b2f061e2-af84-4ddc-8e39-f5e969ac228f ;;; elint.el ends here diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index eead7004910..bc02d9a7551 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -1,7 +1,7 @@ ;;; elp.el --- Emacs Lisp Profiler -;; Copyright (C) 1994, 1995, 1997, 1998, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1994-1995, 1997-1998, 2001-2013 Free Software +;; Foundation, Inc. ;; Author: Barry A. Warsaw ;; Maintainer: FSF @@ -258,7 +258,7 @@ FUNSYM must be a symbol of a defined function." ;; the autoload here, since that could have side effects, and ;; elp-instrument-function is similar (in my mind) to defun-ish ;; type functionality (i.e. it shouldn't execute the function). - (and (eq (car-safe funguts) 'autoload) + (and (autoloadp funguts) (error "ELP cannot profile autoloaded function: %s" funsym)) ;; We cannot profile functions used internally during profiling. (unless (elp-profilable-p funsym) @@ -282,7 +282,7 @@ FUNSYM must be a symbol of a defined function." ;; 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 + ;; The 1st element is the total amount of time in seconds that has ;; been spent inside this function. This number is added to on ;; function exit. ;; @@ -424,9 +424,7 @@ Use optional LIST if provided instead." (defsubst elp-elapsed-time (start end) - (+ (* (- (car end) (car start)) 65536.0) - (- (car (cdr end)) (car (cdr start))) - (/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0))) + (float-time (time-subtract end start))) (defun elp-wrapper (funsym interactive-p args) "This function has been instrumented for profiling by the ELP. @@ -630,7 +628,7 @@ displayed." 'display (list 'space :align-to column) 'face 'fixed-pitch) title) - (setq column (+ column 1 + (setq column (+ column 2 (if (= column 0) elp-field-len (length title)))))) @@ -660,5 +658,4 @@ displayed." (provide 'elp) -;; arch-tag: c4eef311-9b3e-4bb2-8a54-3485d41b4eb1 ;;; elp.el ends here diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el new file mode 100644 index 00000000000..00100c0f6fb --- /dev/null +++ b/lisp/emacs-lisp/ert-x.el @@ -0,0 +1,291 @@ +;;; ert-x.el --- Staging area for experimental extensions to ERT + +;; Copyright (C) 2008, 2010-2013 Free Software Foundation, Inc. + +;; Author: Lennart Borgman (lennart O borgman A gmail O com) +;; Christian Ohler <ohler@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file includes some extra helper functions to use while writing +;; automated tests with ERT. These have been proposed as extensions +;; to ERT but are not mature yet and likely to change. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'ert) + + +;;; Test buffers. + +(defun ert--text-button (string &rest properties) + "Return a string containing STRING as a text button with PROPERTIES. + +See `make-text-button'." + (with-temp-buffer + (insert string) + (apply #'make-text-button (point-min) (point-max) properties) + (buffer-string))) + +(defun ert--format-test-buffer-name (base-name) + "Compute a test buffer name based on BASE-NAME. + +Helper function for `ert--test-buffers'." + (format "*Test buffer (%s)%s*" + (or (and (ert-running-test) + (ert-test-name (ert-running-test))) + "<anonymous test>") + (if base-name + (format ": %s" base-name) + ""))) + +(defvar ert--test-buffers (make-hash-table :weakness t) + "Table of all test buffers. Keys are the buffer objects, values are t. + +The main use of this table is for `ert-kill-all-test-buffers'. +Not all buffers in this table are necessarily live, but all live +test buffers are in this table.") + +(define-button-type 'ert--test-buffer-button + 'action #'ert--test-buffer-button-action + 'help-echo "mouse-2, RET: Pop to test buffer") + +(defun ert--test-buffer-button-action (button) + "Pop to the test buffer that BUTTON is associated with." + (pop-to-buffer (button-get button 'ert--test-buffer))) + +(defun ert--call-with-test-buffer (ert--base-name ert--thunk) + "Helper function for `ert-with-test-buffer'. + +Create a test buffer with a name based on ERT--BASE-NAME and run +ERT--THUNK with that buffer as current." + (let* ((ert--buffer (generate-new-buffer + (ert--format-test-buffer-name ert--base-name))) + (ert--button (ert--text-button (buffer-name ert--buffer) + :type 'ert--test-buffer-button + 'ert--test-buffer ert--buffer))) + (puthash ert--buffer 't ert--test-buffers) + ;; We don't use `unwind-protect' here since we want to kill the + ;; buffer only on success. + (prog1 (with-current-buffer ert--buffer + (ert-info (ert--button :prefix "Buffer: ") + (funcall ert--thunk))) + (kill-buffer ert--buffer) + (remhash ert--buffer ert--test-buffers)))) + +(defmacro* ert-with-test-buffer ((&key ((:name name-form))) + &body body) + "Create a test buffer and run BODY in that buffer. + +To be used in ERT tests. If BODY finishes successfully, the test +buffer is killed; if there is an error, the test buffer is kept +around on error for further inspection. Its name is derived from +the name of the test and the result of NAME-FORM." + (declare (debug ((form) body)) + (indent 1)) + `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) + +;; We use these `put' forms in addition to the (declare (indent)) in +;; the defmacro form since the `declare' alone does not lead to +;; correct indentation before the .el/.elc file is loaded. +;; Autoloading these `put' forms solves this. +;;;###autoload +(progn + ;; TODO(ohler): Figure out what these mean and make sure they are correct. + (put 'ert-with-test-buffer 'lisp-indent-function 1)) + +;;;###autoload +(defun ert-kill-all-test-buffers () + "Kill all test buffers that are still live." + (interactive) + (let ((count 0)) + (maphash (lambda (buffer dummy) + (when (or (not (buffer-live-p buffer)) + (kill-buffer buffer)) + (incf count))) + ert--test-buffers) + (message "%s out of %s test buffers killed" + count (hash-table-count ert--test-buffers))) + ;; It could be that some test buffers were actually kept alive + ;; (e.g., due to `kill-buffer-query-functions'). I'm not sure what + ;; to do about this. For now, let's just forget them. + (clrhash ert--test-buffers) + nil) + + +;;; Simulate commands. + +(defun ert-simulate-command (command) + ;; FIXME: add unread-events + "Simulate calling COMMAND the way the Emacs command loop would call it. + +This effectively executes + + \(apply (car COMMAND) (cdr COMMAND)\) + +and returns the same value, but additionally runs hooks like +`pre-command-hook' and `post-command-hook', and sets variables +like `this-command' and `last-command'. + +COMMAND should be a list where the car is the command symbol and +the rest are arguments to the command. + +NOTE: Since the command is not called by `call-interactively' +test for `called-interactively' in the command will fail." + (assert (listp command) t) + (assert (commandp (car command)) t) + (assert (not unread-command-events) t) + (let (return-value) + ;; For the order of things here see command_loop_1 in keyboard.c. + ;; + ;; The command loop will reset the command-related variables so + ;; there is no reason to let-bind them. They are set here, + ;; however, to be able to test several commands in a row and how + ;; they affect each other. + (setq deactivate-mark nil + this-original-command (car command) + ;; remap through active keymaps + this-command (or (command-remapping this-original-command) + this-original-command)) + (run-hooks 'pre-command-hook) + (setq return-value (apply (car command) (cdr command))) + (run-hooks 'post-command-hook) + (and (boundp 'deferred-action-list) + deferred-action-list + (run-hooks 'deferred-action-function)) + (setq real-last-command (car command) + last-command this-command) + (when (boundp 'last-repeatable-command) + (setq last-repeatable-command real-last-command)) + (when (and deactivate-mark transient-mark-mode) (deactivate-mark)) + (assert (not unread-command-events) t) + return-value)) + +(defun ert-run-idle-timers () + "Run all idle timers (from `timer-idle-list')." + (dolist (timer (copy-sequence timer-idle-list)) + (timer-event-handler timer))) + + +;;; Miscellaneous utilities. + +(defun ert-filter-string (s &rest regexps) + "Return a copy of S with all matches of REGEXPS removed. + +Elements of REGEXPS may also be two-element lists \(REGEXP +SUBEXP\), where SUBEXP is the number of a subexpression in +REGEXP. In that case, only that subexpression will be removed +rather than the entire match." + ;; Use a temporary buffer since replace-match copies strings, which + ;; would lead to N^2 runtime. + (with-temp-buffer + (insert s) + (dolist (x regexps) + (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (replace-match "" t t nil subexp)))) + (buffer-string))) + + +(defun ert-propertized-string (&rest args) + "Return a string with properties as specified by ARGS. + +ARGS is a list of strings and plists. The strings in ARGS are +concatenated to produce an output string. In the output string, +each string from ARGS will be have the preceding plist as its +property list, or no properties if there is no plist before it. + +As a simple example, + +\(ert-propertized-string \"foo \" '(face italic) \"bar\" \" baz\" nil \ +\" quux\"\) + +would return the string \"foo bar baz quux\" where the substring +\"bar baz\" has a `face' property with the value `italic'. + +None of the ARGS are modified, but the return value may share +structure with the plists in ARGS." + (with-temp-buffer + (loop with current-plist = nil + for x in args do + (etypecase x + (string (let ((begin (point))) + (insert x) + (set-text-properties begin (point) current-plist))) + (list (unless (zerop (mod (length x) 2)) + (error "Odd number of args in plist: %S" x)) + (setq current-plist x)))) + (buffer-string))) + + +(defun ert-call-with-buffer-renamed (buffer-name thunk) + "Protect the buffer named BUFFER-NAME from side-effects and run THUNK. + +Renames the buffer BUFFER-NAME to a new temporary name, creates a +new buffer named BUFFER-NAME, executes THUNK, kills the new +buffer, and renames the original buffer back to BUFFER-NAME. + +This is useful if THUNK has undesirable side-effects on an Emacs +buffer with a fixed name such as *Messages*." + (lexical-let ((new-buffer-name (generate-new-buffer-name + (format "%s orig buffer" buffer-name)))) + (with-current-buffer (get-buffer-create buffer-name) + (rename-buffer new-buffer-name)) + (unwind-protect + (progn + (get-buffer-create buffer-name) + (funcall thunk)) + (when (get-buffer buffer-name) + (kill-buffer buffer-name)) + (with-current-buffer new-buffer-name + (rename-buffer buffer-name))))) + +(defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body) + "Protect the buffer named BUFFER-NAME from side-effects and run BODY. + +See `ert-call-with-buffer-renamed' for details." + (declare (indent 1)) + `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () ,@body))) + + +(defun ert-buffer-string-reindented (&optional buffer) + "Return the contents of BUFFER after reindentation. + +BUFFER defaults to current buffer. Does not modify BUFFER." + (with-current-buffer (or buffer (current-buffer)) + (let ((clone nil)) + (unwind-protect + (progn + ;; `clone-buffer' doesn't work if `buffer-file-name' is non-nil. + (let ((buffer-file-name nil)) + (setq clone (clone-buffer))) + (with-current-buffer clone + (let ((inhibit-read-only t)) + (indent-region (point-min) (point-max))) + (buffer-string))) + (when clone + (let ((kill-buffer-query-functions nil)) + (kill-buffer clone))))))) + + +(provide 'ert-x) + +;;; ert-x.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el new file mode 100644 index 00000000000..134dbc1b6a6 --- /dev/null +++ b/lisp/emacs-lisp/ert.el @@ -0,0 +1,2542 @@ +;;; ert.el --- Emacs Lisp Regression Testing + +;; Copyright (C) 2007-2008, 2010-2013 Free Software Foundation, Inc. + +;; Author: Christian Ohler <ohler@gnu.org> +;; Keywords: lisp, tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; ERT is a tool for automated testing in Emacs Lisp. Its main +;; features are facilities for defining and running test cases and +;; reporting the results as well as for debugging test failures +;; interactively. +;; +;; The main entry points are `ert-deftest', which is similar to +;; `defun' but defines a test, and `ert-run-tests-interactively', +;; which runs tests and offers an interactive interface for inspecting +;; results and debugging. There is also +;; `ert-run-tests-batch-and-exit' for non-interactive use. +;; +;; The body of `ert-deftest' forms resembles a function body, but the +;; additional operators `should', `should-not' and `should-error' are +;; available. `should' is similar to cl's `assert', but signals a +;; different error when its condition is violated that is caught and +;; processed by ERT. In addition, it analyzes its argument form and +;; records information that helps debugging (`assert' tries to do +;; something similar when its second argument SHOW-ARGS is true, but +;; `should' is more sophisticated). For information on `should-not' +;; and `should-error', see their docstrings. +;; +;; See ERT's info manual as well as the docstrings for more details. +;; To compile the manual, run `makeinfo ert.texinfo' in the ERT +;; directory, then C-u M-x info ert.info in Emacs to view it. +;; +;; To see some examples of tests written in ERT, see its self-tests in +;; ert-tests.el. Some of these are tricky due to the bootstrapping +;; problem of writing tests for a testing tool, others test simple +;; functions and are straightforward. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'button) +(require 'debug) +(require 'easymenu) +(require 'ewoc) +(require 'find-func) +(require 'help) + + +;;; UI customization options. + +(defgroup ert () + "ERT, the Emacs Lisp regression testing tool." + :prefix "ert-" + :group 'lisp) + +(defface ert-test-result-expected '((((class color) (background light)) + :background "green1") + (((class color) (background dark)) + :background "green3")) + "Face used for expected results in the ERT results buffer." + :group 'ert) + +(defface ert-test-result-unexpected '((((class color) (background light)) + :background "red1") + (((class color) (background dark)) + :background "red3")) + "Face used for unexpected results in the ERT results buffer." + :group 'ert) + + +;;; Copies/reimplementations of cl functions. + +(defun ert--cl-do-remf (plist tag) + "Copy of `cl-do-remf'. Modify PLIST by removing 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 ert--remprop (sym tag) + "Copy of `cl-remprop'. Modify SYM's plist by removing TAG." + (let ((plist (symbol-plist sym))) + (if (and plist (eq tag (car plist))) + (progn (setplist sym (cdr (cdr plist))) t) + (ert--cl-do-remf plist tag)))) + +(defun ert--remove-if-not (ert-pred ert-list) + "A reimplementation of `remove-if-not'. + +ERT-PRED is a predicate, ERT-LIST is the input list." + (loop for ert-x in ert-list + if (funcall ert-pred ert-x) + collect ert-x)) + +(defun ert--intersection (a b) + "A reimplementation of `intersection'. Intersect the sets A and B. + +Elements are compared using `eql'." + (loop for x in a + if (memql x b) + collect x)) + +(defun ert--set-difference (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eql'." + (loop for x in a + unless (memql x b) + collect x)) + +(defun ert--set-difference-eq (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eq'." + (loop for x in a + unless (memq x b) + collect x)) + +(defun ert--union (a b) + "A reimplementation of `union'. Compute the union of the sets A and B. + +Elements are compared using `eql'." + (append a (ert--set-difference b a))) + +(eval-and-compile + (defvar ert--gensym-counter 0)) + +(eval-and-compile + (defun ert--gensym (&optional prefix) + "Only allows string PREFIX, not compatible with CL." + (unless prefix (setq prefix "G")) + (make-symbol (format "%s%s" + prefix + (prog1 ert--gensym-counter + (incf ert--gensym-counter)))))) + +(defun ert--coerce-to-vector (x) + "Coerce X to a vector." + (when (char-table-p x) (error "Not supported")) + (if (vectorp x) + x + (vconcat x))) + +(defun* ert--remove* (x list &key key test) + "Does not support all the keywords of remove*." + (unless key (setq key #'identity)) + (unless test (setq test #'eql)) + (loop for y in list + unless (funcall test x (funcall key y)) + collect y)) + +(defun ert--string-position (c s) + "Return the position of the first occurrence of C in S, or nil if none." + (loop for i from 0 + for x across s + when (eql x c) return i)) + +(defun ert--mismatch (a b) + "Return index of first element that differs between A and B. + +Like `mismatch'. Uses `equal' for comparison." + (cond ((or (listp a) (listp b)) + (ert--mismatch (ert--coerce-to-vector a) + (ert--coerce-to-vector b))) + ((> (length a) (length b)) + (ert--mismatch b a)) + (t + (let ((la (length a)) + (lb (length b))) + (assert (arrayp a) t) + (assert (arrayp b) t) + (assert (<= la lb) t) + (loop for i below la + when (not (equal (aref a i) (aref b i))) return i + finally (return (if (/= la lb) + la + (assert (equal a b) t) + nil))))))) + +(defun ert--subseq (seq start &optional end) + "Return a subsequence of SEQ from START to END." + (when (char-table-p seq) (error "Not supported")) + (let ((vector (substring (ert--coerce-to-vector seq) start end))) + (etypecase seq + (vector vector) + (string (concat vector)) + (list (append vector nil)) + (bool-vector (loop with result = (make-bool-vector (length vector) nil) + for i below (length vector) do + (setf (aref result i) (aref vector i)) + finally (return result))) + (char-table (assert nil))))) + +(defun ert-equal-including-properties (a b) + "Return t if A and B have similar structure and contents. + +This is like `equal-including-properties' except that it compares +the property values of text properties structurally (by +recursing) rather than with `eq'. Perhaps this is what +`equal-including-properties' should do in the first place; see +Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." + ;; This implementation is inefficient. Rather than making it + ;; efficient, let's hope bug 6581 gets fixed so that we can delete + ;; it altogether. + (not (ert--explain-equal-including-properties a b))) + + +;;; Defining and locating tests. + +;; The data structure that represents a test case. +(defstruct ert-test + (name nil) + (documentation nil) + (body (assert nil)) + (most-recent-result nil) + (expected-result-type ':passed) + (tags '())) + +(defun ert-test-boundp (symbol) + "Return non-nil if SYMBOL names a test." + (and (get symbol 'ert--test) t)) + +(defun ert-get-test (symbol) + "If SYMBOL names a test, return that. Signal an error otherwise." + (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) + (get symbol 'ert--test)) + +(defun ert-set-test (symbol definition) + "Make SYMBOL name the test DEFINITION, and return DEFINITION." + (when (eq symbol 'nil) + ;; We disallow nil since `ert-test-at-point' and related functions + ;; want to return a test name, but also need an out-of-band value + ;; on failure. Nil is the most natural out-of-band value; using 0 + ;; or "" or signaling an error would be too awkward. + ;; + ;; Note that nil is still a valid value for the `name' slot in + ;; ert-test objects. It designates an anonymous test. + (error "Attempt to define a test named nil")) + (put symbol 'ert--test definition) + definition) + +(defun ert-make-test-unbound (symbol) + "Make SYMBOL name no test. Return SYMBOL." + (ert--remprop symbol 'ert--test) + symbol) + +(defun ert--parse-keys-and-body (keys-and-body) + "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. + +KEYS-AND-BODY should have the form of a property list, with the +exception that only keywords are permitted as keys and that the +tail -- the body -- is a list of forms that does not start with a +keyword. + +Returns a two-element list containing the keys-and-values plist +and the body." + (let ((extracted-key-accu '()) + (remaining keys-and-body)) + (while (and (consp remaining) (keywordp (first remaining))) + (let ((keyword (pop remaining))) + (unless (consp remaining) + (error "Value expected after keyword %S in %S" + keyword keys-and-body)) + (when (assoc keyword extracted-key-accu) + (warn "Keyword %S appears more than once in %S" keyword + keys-and-body)) + (push (cons keyword (pop remaining)) extracted-key-accu))) + (setq extracted-key-accu (nreverse extracted-key-accu)) + (list (loop for (key . value) in extracted-key-accu + collect key + collect value) + remaining))) + +;;;###autoload +(defmacro* ert-deftest (name () &body docstring-keys-and-body) + "Define NAME (a symbol) as a test. + +BODY is evaluated as a `progn' when the test is run. It should +signal a condition on failure or just return if the test passes. + +`should', `should-not' and `should-error' are useful for +assertions in BODY. + +Use `ert' to run tests interactively. + +Tests that are expected to fail can be marked as such +using :expected-result. See `ert-test-result-type-p' for a +description of valid values for RESULT-TYPE. + +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +\[:tags '(TAG...)] BODY...)" + (declare (debug (&define :name test + name sexp [&optional stringp] + [&rest keywordp sexp] def-body)) + (doc-string 3) + (indent 2)) + (let ((documentation nil) + (documentation-supplied-p nil)) + (when (stringp (first docstring-keys-and-body)) + (setq documentation (pop docstring-keys-and-body) + documentation-supplied-p t)) + (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) + (tags nil tags-supplied-p)) + body) + (ert--parse-keys-and-body docstring-keys-and-body) + `(progn + (ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when expected-result-supplied-p + `(:expected-result-type ,expected-result)) + ,@(when tags-supplied-p + `(:tags ,tags)) + :body (lambda () ,@body))) + ;; This hack allows `symbol-file' to associate `ert-deftest' + ;; forms with files, and therefore enables `find-function' to + ;; work with tests. However, it leads to warnings in + ;; `unload-feature', which doesn't know how to undefine tests + ;; and has no mechanism for extension. + (push '(ert-deftest . ,name) current-load-list) + ',name)))) + +;; We use these `put' forms in addition to the (declare (indent)) in +;; the defmacro form since the `declare' alone does not lead to +;; correct indentation before the .el/.elc file is loaded. +;; Autoloading these `put' forms solves this. +;;;###autoload +(progn + ;; TODO(ohler): Figure out what these mean and make sure they are correct. + (put 'ert-deftest 'lisp-indent-function 2) + (put 'ert-info 'lisp-indent-function 1)) + +(defvar ert--find-test-regexp + (concat "^\\s-*(ert-deftest" + find-function-space-re + "%s\\(\\s-\\|$\\)") + "The regexp the `find-function' mechanisms use for finding test definitions.") + + +(put 'ert-test-failed 'error-conditions '(error ert-test-failed)) +(put 'ert-test-failed 'error-message "Test failed") + +(defun ert-pass () + "Terminate the current test and mark it passed. Does not return." + (throw 'ert--pass nil)) + +(defun ert-fail (data) + "Terminate the current test and mark it failed. Does not return. +DATA is displayed to the user and should state the reason of the failure." + (signal 'ert-test-failed (list data))) + + +;;; The `should' macros. + +(defvar ert--should-execution-observer nil) + +(defun ert--signal-should-execution (form-description) + "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." + (when ert--should-execution-observer + (funcall ert--should-execution-observer form-description))) + +(defun ert--special-operator-p (thing) + "Return non-nil if THING is a symbol naming a special operator." + (and (symbolp thing) + (let ((definition (indirect-function thing t))) + (and (subrp definition) + (eql (cdr (subr-arity definition)) 'unevalled))))) + +(defun ert--expand-should-1 (whole form inner-expander) + "Helper function for the `should' macro and its variants." + (let ((form + (macroexpand form (cond + ((boundp 'macroexpand-all-environment) + macroexpand-all-environment) + ((boundp 'cl-macro-environment) + cl-macro-environment))))) + (cond + ((or (atom form) (ert--special-operator-p (car form))) + (let ((value (ert--gensym "value-"))) + `(let ((,value (ert--gensym "ert-form-evaluation-aborted-"))) + ,(funcall inner-expander + `(setq ,value ,form) + `(list ',whole :form ',form :value ,value) + value) + ,value))) + (t + (let ((fn-name (car form)) + (arg-forms (cdr form))) + (assert (or (symbolp fn-name) + (and (consp fn-name) + (eql (car fn-name) 'lambda) + (listp (cdr fn-name))))) + (let ((fn (ert--gensym "fn-")) + (args (ert--gensym "args-")) + (value (ert--gensym "value-")) + (default-value (ert--gensym "ert-form-evaluation-aborted-"))) + `(let ((,fn (function ,fn-name)) + (,args (list ,@arg-forms))) + (let ((,value ',default-value)) + ,(funcall inner-expander + `(setq ,value (apply ,fn ,args)) + `(nconc (list ',whole) + (list :form `(,,fn ,@,args)) + (unless (eql ,value ',default-value) + (list :value ,value)) + (let ((-explainer- + (and (symbolp ',fn-name) + (get ',fn-name 'ert-explainer)))) + (when -explainer- + (list :explanation + (apply -explainer- ,args))))) + value) + ,value)))))))) + +(defun ert--expand-should (whole form inner-expander) + "Helper function for the `should' macro and its variants. + +Analyzes FORM and returns an expression that has the same +semantics under evaluation but records additional debugging +information. + +INNER-EXPANDER should be a function and is called with two +arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM +is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is +an expression that returns a description of FORM. INNER-EXPANDER +should return code that calls INNER-FORM and performs the checks +and error signaling specific to the particular variant of +`should'. The code that INNER-EXPANDER returns must not call +FORM-DESCRIPTION-FORM before it has called INNER-FORM." + (lexical-let ((inner-expander inner-expander)) + (ert--expand-should-1 + whole form + (lambda (inner-form form-description-form value-var) + (let ((form-description (ert--gensym "form-description-"))) + `(let (,form-description) + ,(funcall inner-expander + `(unwind-protect + ,inner-form + (setq ,form-description ,form-description-form) + (ert--signal-should-execution ,form-description)) + `,form-description + value-var))))))) + +(defmacro* should (form) + "Evaluate FORM. If it returns nil, abort the current test as failed. + +Returns the value of FORM." + (ert--expand-should `(should ,form) form + (lambda (inner-form form-description-form value-var) + `(unless ,inner-form + (ert-fail ,form-description-form))))) + +(defmacro* should-not (form) + "Evaluate FORM. If it returns non-nil, abort the current test as failed. + +Returns nil." + (ert--expand-should `(should-not ,form) form + (lambda (inner-form form-description-form value-var) + `(unless (not ,inner-form) + (ert-fail ,form-description-form))))) + +(defun ert--should-error-handle-error (form-description-fn + condition type exclude-subtypes) + "Helper function for `should-error'. + +Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, +and aborts the current test as failed if it doesn't." + (let ((signaled-conditions (get (car condition) 'error-conditions)) + (handled-conditions (etypecase type + (list type) + (symbol (list type))))) + (assert signaled-conditions) + (unless (ert--intersection signaled-conditions handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signaled did not" + " have the expected type"))))) + (when exclude-subtypes + (unless (member (car condition) handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signaled was a subtype" + " of the expected type")))))))) + +;; FIXME: The expansion will evaluate the keyword args (if any) in +;; nonstandard order. +(defmacro* should-error (form &rest keys &key type exclude-subtypes) + "Evaluate FORM and check that it signals an error. + +The error signaled needs to match TYPE. TYPE should be a list +of condition names. (It can also be a non-nil symbol, which is +equivalent to a singleton list containing that symbol.) If +EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its +condition names is an element of TYPE. If EXCLUDE-SUBTYPES is +non-nil, the error matches TYPE if it is an element of TYPE. + +If the error matches, returns (ERROR-SYMBOL . DATA) from the +error. If not, or if no error was signaled, abort the test as +failed." + (unless type (setq type ''error)) + (ert--expand-should + `(should-error ,form ,@keys) + form + (lambda (inner-form form-description-form value-var) + (let ((errorp (ert--gensym "errorp")) + (form-description-fn (ert--gensym "form-description-fn-"))) + `(let ((,errorp nil) + (,form-description-fn (lambda () ,form-description-form))) + (condition-case -condition- + ,inner-form + ;; We can't use ,type here because we want to evaluate it. + (error + (setq ,errorp t) + (ert--should-error-handle-error ,form-description-fn + -condition- + ,type ,exclude-subtypes) + (setq ,value-var -condition-))) + (unless ,errorp + (ert-fail (append + (funcall ,form-description-fn) + (list + :fail-reason "did not signal an error"))))))))) + + +;;; Explanation of `should' failures. + +;; TODO(ohler): Rework explanations so that they are displayed in a +;; similar way to `ert-info' messages; in particular, allow text +;; buttons in explanations that give more detail or open an ediff +;; buffer. Perhaps explanations should be reported through `ert-info' +;; rather than as part of the condition. + +(defun ert--proper-list-p (x) + "Return non-nil if X is a proper list, nil otherwise." + (loop + for firstp = t then nil + for fast = x then (cddr fast) + for slow = x then (cdr slow) do + (when (null fast) (return t)) + (when (not (consp fast)) (return nil)) + (when (null (cdr fast)) (return t)) + (when (not (consp (cdr fast))) (return nil)) + (when (and (not firstp) (eq fast slow)) (return nil)))) + +(defun ert--explain-format-atom (x) + "Format the atom X for `ert--explain-equal'." + (typecase x + (fixnum (list x (format "#x%x" x) (format "?%c" x))) + (t x))) + +(defun ert--explain-equal-rec (a b) + "Return a programmer-readable explanation of why A and B are not `equal'. +Returns nil if they are." + (if (not (equal (type-of a) (type-of b))) + `(different-types ,a ,b) + (etypecase a + (cons + (let ((a-proper-p (ert--proper-list-p a)) + (b-proper-p (ert--proper-list-p b))) + (if (not (eql (not a-proper-p) (not b-proper-p))) + `(one-list-proper-one-improper ,a ,b) + (if a-proper-p + (if (not (equal (length a) (length b))) + `(proper-lists-of-different-length ,(length a) ,(length b) + ,a ,b + first-mismatch-at + ,(ert--mismatch a b)) + (loop for i from 0 + for ai in a + for bi in b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (return `(list-elt ,i ,xi))) + finally (assert (equal a b) t))) + (let ((car-x (ert--explain-equal-rec (car a) (car b)))) + (if car-x + `(car ,car-x) + (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b)))) + (if cdr-x + `(cdr ,cdr-x) + (assert (equal a b) t) + nil)))))))) + (array (if (not (equal (length a) (length b))) + `(arrays-of-different-length ,(length a) ,(length b) + ,a ,b + ,@(unless (char-table-p a) + `(first-mismatch-at + ,(ert--mismatch a b)))) + (loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (return `(array-elt ,i ,xi))) + finally (assert (equal a b) t)))) + (atom (if (not (equal a b)) + (if (and (symbolp a) (symbolp b) (string= a b)) + `(different-symbols-with-the-same-name ,a ,b) + `(different-atoms ,(ert--explain-format-atom a) + ,(ert--explain-format-atom b))) + nil))))) + +(defun ert--explain-equal (a b) + "Explainer function for `equal'." + ;; Do a quick comparison in C to avoid running our expensive + ;; comparison when possible. + (if (equal a b) + nil + (ert--explain-equal-rec a b))) +(put 'equal 'ert-explainer 'ert--explain-equal) + +(defun ert--significant-plist-keys (plist) + "Return the keys of PLIST that have non-null values, in order." + (assert (zerop (mod (length plist) 2)) t) + (loop for (key value . rest) on plist by #'cddr + unless (or (null value) (memq key accu)) collect key into accu + finally (return accu))) + +(defun ert--plist-difference-explanation (a b) + "Return a programmer-readable explanation of why A and B are different plists. + +Returns nil if they are equivalent, i.e., have the same value for +each key, where absent values are treated as nil. The order of +key/value pairs in each list does not matter." + (assert (zerop (mod (length a) 2)) t) + (assert (zerop (mod (length b) 2)) t) + ;; Normalizing the plists would be another way to do this but it + ;; requires a total ordering on all lisp objects (since any object + ;; is valid as a text property key). Perhaps defining such an + ;; ordering is useful in other contexts, too, but it's a lot of + ;; work, so let's punt on it for now. + (let* ((keys-a (ert--significant-plist-keys a)) + (keys-b (ert--significant-plist-keys b)) + (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) + (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) + (flet ((explain-with-key (key) + (let ((value-a (plist-get a key)) + (value-b (plist-get b key))) + (assert (not (equal value-a value-b)) t) + `(different-properties-for-key + ,key ,(ert--explain-equal-including-properties value-a + value-b))))) + (cond (keys-in-a-not-in-b + (explain-with-key (first keys-in-a-not-in-b))) + (keys-in-b-not-in-a + (explain-with-key (first keys-in-b-not-in-a))) + (t + (loop for key in keys-a + when (not (equal (plist-get a key) (plist-get b key))) + return (explain-with-key key))))))) + +(defun ert--abbreviate-string (s len suffixp) + "Shorten string S to at most LEN chars. + +If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." + (let ((n (length s))) + (cond ((< n len) + s) + (suffixp + (substring s (- n len))) + (t + (substring s 0 len))))) + +;; TODO(ohler): Once bug 6581 is fixed, rename this to +;; `ert--explain-equal-including-properties-rec' and add a fast-path +;; wrapper like `ert--explain-equal'. +(defun ert--explain-equal-including-properties (a b) + "Explainer function for `ert-equal-including-properties'. + +Returns a programmer-readable explanation of why A and B are not +`ert-equal-including-properties', or nil if they are." + (if (not (equal a b)) + (ert--explain-equal a b) + (assert (stringp a) t) + (assert (stringp b) t) + (assert (eql (length a) (length b)) t) + (loop for i from 0 to (length a) + for props-a = (text-properties-at i a) + for props-b = (text-properties-at i b) + for difference = (ert--plist-difference-explanation props-a props-b) + do (when difference + (return `(char ,i ,(substring-no-properties a i (1+ i)) + ,difference + context-before + ,(ert--abbreviate-string + (substring-no-properties a 0 i) + 10 t) + context-after + ,(ert--abbreviate-string + (substring-no-properties a (1+ i)) + 10 nil)))) + ;; TODO(ohler): Get `equal-including-properties' fixed in + ;; Emacs, delete `ert-equal-including-properties', and + ;; re-enable this assertion. + ;;finally (assert (equal-including-properties a b) t) + ))) +(put 'ert-equal-including-properties + 'ert-explainer + 'ert--explain-equal-including-properties) + + +;;; Implementation of `ert-info'. + +;; TODO(ohler): The name `info' clashes with +;; `ert--test-execution-info'. One or both should be renamed. +(defvar ert--infos '() + "The stack of `ert-info' infos that currently apply. + +Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") + +(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) + &body body) + "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. + +To be used within ERT tests. MESSAGE-FORM should evaluate to a +string that will be displayed together with the test result if +the test fails. PREFIX-FORM should evaluate to a string as well +and is displayed in front of the value of MESSAGE-FORM." + (declare (debug ((form &rest [sexp form]) body)) + (indent 1)) + `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) + ,@body)) + + + +;;; Facilities for running a single test. + +(defvar ert-debug-on-error nil + "Non-nil means enter debugger when a test fails or terminates with an error.") + +;; The data structures that represent the result of running a test. +(defstruct ert-test-result + (messages nil) + (should-forms nil) + ) +(defstruct (ert-test-passed (:include ert-test-result))) +(defstruct (ert-test-result-with-condition (:include ert-test-result)) + (condition (assert nil)) + (backtrace (assert nil)) + (infos (assert nil))) +(defstruct (ert-test-quit (:include ert-test-result-with-condition))) +(defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) + + +(defun ert--record-backtrace () + "Record the current backtrace (as a list) and return it." + ;; Since the backtrace is stored in the result object, result + ;; objects must only be printed with appropriate limits + ;; (`print-level' and `print-length') in place. For interactive + ;; use, the cost of ensuring this possibly outweighs the advantage + ;; of storing the backtrace for + ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we + ;; already have `ert-results-rerun-test-debugging-errors-at-point'. + ;; For batch use, however, printing the backtrace may be useful. + (loop + ;; 6 is the number of frames our own debugger adds (when + ;; compiled; more when interpreted). FIXME: Need to describe a + ;; procedure for determining this constant. + for i from 6 + for frame = (backtrace-frame i) + while frame + collect frame)) + +(defun ert--print-backtrace (backtrace) + "Format the backtrace BACKTRACE to the current buffer." + ;; This is essentially a reimplementation of Fbacktrace + ;; (src/eval.c), but for a saved backtrace, not the current one. + (let ((print-escape-newlines t) + (print-level 8) + (print-length 50)) + (dolist (frame backtrace) + (ecase (first frame) + ((nil) + ;; Special operator. + (destructuring-bind (special-operator &rest arg-forms) + (cdr frame) + (insert + (format " %S\n" (list* special-operator arg-forms))))) + ((t) + ;; Function call. + (destructuring-bind (fn &rest args) (cdr frame) + (insert (format " %S(" fn)) + (loop for firstp = t then nil + for arg in args do + (unless firstp + (insert " ")) + (insert (format "%S" arg))) + (insert ")\n"))))))) + +;; A container for the state of the execution of a single test and +;; environment data needed during its execution. +(defstruct ert--test-execution-info + (test (assert nil)) + (result (assert nil)) + ;; A thunk that may be called when RESULT has been set to its final + ;; value and test execution should be terminated. Should not + ;; return. + (exit-continuation (assert nil)) + ;; The binding of `debugger' outside of the execution of the test. + next-debugger + ;; The binding of `ert-debug-on-error' that is in effect for the + ;; execution of the current test. We store it to avoid being + ;; affected by any new bindings the test itself may establish. (I + ;; don't remember whether this feature is important.) + ert-debug-on-error) + +(defun ert--run-test-debugger (info debugger-args) + "During a test run, `debugger' is bound to a closure that calls this function. + +This function records failures and errors and either terminates +the test silently or calls the interactive debugger, as +appropriate. + +INFO is the ert--test-execution-info corresponding to this test +run. DEBUGGER-ARGS are the arguments to `debugger'." + (destructuring-bind (first-debugger-arg &rest more-debugger-args) + debugger-args + (ecase first-debugger-arg + ((lambda debug t exit nil) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (error + (let* ((condition (first more-debugger-args)) + (type (case (car condition) + ((quit) 'quit) + (otherwise 'failed))) + (backtrace (ert--record-backtrace)) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (ecase type + (quit + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + (failed + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))) + ;; Work around Emacs's heuristic (in eval.c) for detecting + ;; errors in the debugger. + (incf num-nonmacro-input-events) + ;; FIXME: We should probably implement more fine-grained + ;; control a la non-t `debug-on-error' here. + (cond + ((ert--test-execution-info-ert-debug-on-error info) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (t)) + (funcall (ert--test-execution-info-exit-continuation info))))))) + +(defun ert--run-test-internal (ert-test-execution-info) + "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. + +This mainly sets up debugger-related bindings." + (lexical-let ((info ert-test-execution-info)) + (setf (ert--test-execution-info-next-debugger info) debugger + (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((debugger (lambda (&rest debugger-args) + (ert--run-test-debugger info debugger-args))) + (debug-on-error t) + (debug-on-quit t) + ;; FIXME: Do we need to store the old binding of this + ;; and consider it in `ert--run-test-debugger'? + (debug-ignored-errors nil) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test info)))))) + (ert-pass)) + (setf (ert--test-execution-info-result info) (make-ert-test-passed))) + nil) + +(defun ert--force-message-log-buffer-truncation () + "Immediately truncate *Messages* buffer according to `message-log-max'. + +This can be useful after reducing the value of `message-log-max'." + (with-current-buffer (get-buffer-create "*Messages*") + ;; This is a reimplementation of this part of message_dolog() in xdisp.c: + ;; if (NATNUMP (Vmessage_log_max)) + ;; { + ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, + ;; -XFASTINT (Vmessage_log_max) - 1, 0); + ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); + ;; } + (when (and (integerp message-log-max) (>= message-log-max 0)) + (let ((begin (point-min)) + (end (save-excursion + (goto-char (point-max)) + (forward-line (- message-log-max)) + (point)))) + (delete-region begin end))))) + +(defvar ert--running-tests nil + "List of tests that are currently in execution. + +This list is empty while no test is running, has one element +while a test is running, two elements while a test run from +inside a test is running, etc. The list is in order of nesting, +innermost test first. + +The elements are of type `ert-test'.") + +(defun ert-run-test (ert-test) + "Run ERT-TEST. + +Returns the result and stores it in ERT-TEST's `most-recent-result' slot." + (setf (ert-test-most-recent-result ert-test) nil) + (block error + (lexical-let ((begin-marker + (with-current-buffer (get-buffer-create "*Messages*") + (set-marker (make-marker) (point-max))))) + (unwind-protect + (lexical-let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit) + :exit-continuation (lambda () + (return-from error nil)))) + (should-form-accu (list))) + (unwind-protect + (let ((ert--should-execution-observer + (lambda (form-description) + (push form-description should-form-accu))) + (message-log-max t) + (ert--running-tests (cons ert-test ert--running-tests))) + (ert--run-test-internal info)) + (let ((result (ert--test-execution-info-result info))) + (setf (ert-test-result-messages result) + (with-current-buffer (get-buffer-create "*Messages*") + (buffer-substring begin-marker (point-max)))) + (ert--force-message-log-buffer-truncation) + (setq should-form-accu (nreverse should-form-accu)) + (setf (ert-test-result-should-forms result) + should-form-accu) + (setf (ert-test-most-recent-result ert-test) result)))) + (set-marker begin-marker nil)))) + (ert-test-most-recent-result ert-test)) + +(defun ert-running-test () + "Return the top-level test currently executing." + (car (last ert--running-tests))) + + +;;; Test selectors. + +(defun ert-test-result-type-p (result result-type) + "Return non-nil if RESULT matches type RESULT-TYPE. + +Valid result types: + +nil -- Never matches. +t -- Always matches. +:failed, :passed -- Matches corresponding results. +\(and TYPES...\) -- Matches if all TYPES match. +\(or TYPES...\) -- Matches if some TYPES match. +\(not TYPE\) -- Matches if TYPE does not match. +\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with + RESULT." + ;; It would be easy to add `member' and `eql' types etc., but I + ;; haven't bothered yet. + (etypecase result-type + ((member nil) nil) + ((member t) t) + ((member :failed) (ert-test-failed-p result)) + ((member :passed) (ert-test-passed-p result)) + (cons + (destructuring-bind (operator &rest operands) result-type + (ecase operator + (and + (case (length operands) + (0 t) + (t + (and (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(and ,@(rest operands))))))) + (or + (case (length operands) + (0 nil) + (t + (or (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(or ,@(rest operands))))))) + (not + (assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (first operands)))) + (satisfies + (assert (eql (length operands) 1)) + (funcall (first operands) result))))))) + +(defun ert-test-result-expected-p (test result) + "Return non-nil if TEST's expected result type matches RESULT." + (ert-test-result-type-p result (ert-test-expected-result-type test))) + +(defun ert-select-tests (selector universe) + "Return a list of tests that match SELECTOR. + +UNIVERSE specifies the set of tests to select from; it should be a list +of tests, or t, which refers to all tests named by symbols in `obarray'. + +Valid SELECTORs: + +nil -- Selects the empty set. +t -- Selects UNIVERSE. +:new -- Selects all tests that have not been run yet. +:failed, :passed -- Select tests according to their most recent result. +:expected, :unexpected -- Select tests according to their most recent result. +a string -- A regular expression selecting all tests with matching names. +a test -- (i.e., an object of the ert-test data-type) Selects that test. +a symbol -- Selects the test that the symbol names, errors if none. +\(member TESTS...) -- Selects the elements of TESTS, a list of tests + or symbols naming tests. +\(eql TEST\) -- Selects TEST, a test or a symbol naming a test. +\(and SELECTORS...) -- Selects the tests that match all SELECTORS. +\(or SELECTORS...) -- Selects the tests that match any of the SELECTORS. +\(not SELECTOR) -- Selects all tests that do not match SELECTOR. +\(tag TAG) -- Selects all tests that have TAG on their tags list. + A tag is an arbitrary label you can apply when you define a test. +\(satisfies PREDICATE) -- Selects all tests that satisfy PREDICATE. + PREDICATE is a function that takes an ert-test object as argument, + and returns non-nil if it is selected. + +Only selectors that require a superset of tests, such +as (satisfies ...), strings, :new, etc. make use of UNIVERSE. +Selectors that do not, such as (member ...), just return the +set implied by them without checking whether it is really +contained in UNIVERSE." + ;; This code needs to match the etypecase in + ;; `ert-insert-human-readable-selector'. + (etypecase selector + ((member nil) nil) + ((member t) (etypecase universe + (list universe) + ((member t) (ert-select-tests "" universe)))) + ((member :new) (ert-select-tests + `(satisfies ,(lambda (test) + (null (ert-test-most-recent-result test)))) + universe)) + ((member :failed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':failed))) + universe)) + ((member :passed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':passed))) + universe)) + ((member :expected) (ert-select-tests + `(satisfies + ,(lambda (test) + (ert-test-result-expected-p + test + (ert-test-most-recent-result test)))) + universe)) + ((member :unexpected) (ert-select-tests `(not :expected) universe)) + (string + (etypecase universe + ((member t) (mapcar #'ert-get-test + (apropos-internal selector #'ert-test-boundp))) + (list (ert--remove-if-not (lambda (test) + (and (ert-test-name test) + (string-match selector + (ert-test-name test)))) + universe)))) + (ert-test (list selector)) + (symbol + (assert (ert-test-boundp selector)) + (list (ert-get-test selector))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + (member + (mapcar (lambda (purported-test) + (etypecase purported-test + (symbol (assert (ert-test-boundp purported-test)) + (ert-get-test purported-test)) + (ert-test purported-test))) + operands)) + (eql + (assert (eql (length operands) 1)) + (ert-select-tests `(member ,@operands) universe)) + (and + ;; Do these definitions of AND, NOT and OR satisfy de + ;; Morgan's laws? Should they? + (case (length operands) + (0 (ert-select-tests 't universe)) + (t (ert-select-tests `(and ,@(rest operands)) + (ert-select-tests (first operands) + universe))))) + (not + (assert (eql (length operands) 1)) + (let ((all-tests (ert-select-tests 't universe))) + (ert--set-difference all-tests + (ert-select-tests (first operands) + all-tests)))) + (or + (case (length operands) + (0 (ert-select-tests 'nil universe)) + (t (ert--union (ert-select-tests (first operands) universe) + (ert-select-tests `(or ,@(rest operands)) + universe))))) + (tag + (assert (eql (length operands) 1)) + (let ((tag (first operands))) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe))) + (satisfies + (assert (eql (length operands) 1)) + (ert--remove-if-not (first operands) + (ert-select-tests 't universe)))))))) + +(defun ert--insert-human-readable-selector (selector) + "Insert a human-readable presentation of SELECTOR into the current buffer." + ;; This is needed to avoid printing the (huge) contents of the + ;; `backtrace' slot of the result objects in the + ;; `most-recent-result' slots of test case objects in (eql ...) or + ;; (member ...) selectors. + (labels ((rec (selector) + ;; This code needs to match the etypecase in `ert-select-tests'. + (etypecase selector + ((or (member nil t + :new :failed :passed + :expected :unexpected) + string + symbol) + selector) + (ert-test + (if (ert-test-name selector) + (make-symbol (format "<%S>" (ert-test-name selector))) + (make-symbol "<unnamed test>"))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + ((member eql and not or) + `(,operator ,@(mapcar #'rec operands))) + ((member tag satisfies) + selector))))))) + (insert (format "%S" (rec selector))))) + + +;;; Facilities for running a whole set of tests. + +;; The data structure that contains the set of tests being executed +;; during one particular test run, their results, the state of the +;; execution, and some statistics. +;; +;; The data about results and expected results of tests may seem +;; redundant here, since the test objects also carry such information. +;; However, the information in the test objects may be more recent, it +;; may correspond to a different test run. We need the information +;; that corresponds to this run in order to be able to update the +;; statistics correctly when a test is re-run interactively and has a +;; different result than before. +(defstruct ert--stats + (selector (assert nil)) + ;; The tests, in order. + (tests (assert nil) :type vector) + ;; A map of test names (or the test objects themselves for unnamed + ;; tests) to indices into the `tests' vector. + (test-map (assert nil) :type hash-table) + ;; The results of the tests during this run, in order. + (test-results (assert nil) :type vector) + ;; The start times of the tests, in order, as reported by + ;; `current-time'. + (test-start-times (assert nil) :type vector) + ;; The end times of the tests, in order, as reported by + ;; `current-time'. + (test-end-times (assert nil) :type vector) + (passed-expected 0) + (passed-unexpected 0) + (failed-expected 0) + (failed-unexpected 0) + (start-time nil) + (end-time nil) + (aborted-p nil) + (current-test nil) + ;; The time at or after which the next redisplay should occur, as a + ;; float. + (next-redisplay 0.0)) + +(defun ert-stats-completed-expected (stats) + "Return the number of tests in STATS that had expected results." + (+ (ert--stats-passed-expected stats) + (ert--stats-failed-expected stats))) + +(defun ert-stats-completed-unexpected (stats) + "Return the number of tests in STATS that had unexpected results." + (+ (ert--stats-passed-unexpected stats) + (ert--stats-failed-unexpected stats))) + +(defun ert-stats-completed (stats) + "Number of tests in STATS that have run so far." + (+ (ert-stats-completed-expected stats) + (ert-stats-completed-unexpected stats))) + +(defun ert-stats-total (stats) + "Number of tests in STATS, regardless of whether they have run yet." + (length (ert--stats-tests stats))) + +;; The stats object of the current run, dynamically bound. This is +;; used for the mode line progress indicator. +(defvar ert--current-run-stats nil) + +(defun ert--stats-test-key (test) + "Return the key used for TEST in the test map of ert--stats objects. + +Returns the name of TEST if it has one, or TEST itself otherwise." + (or (ert-test-name test) test)) + +(defun ert--stats-set-test-and-result (stats pos test result) + "Change STATS by replacing the test at position POS with TEST and RESULT. + +Also changes the counters in STATS to match." + (let* ((tests (ert--stats-tests stats)) + (results (ert--stats-test-results stats)) + (old-test (aref tests pos)) + (map (ert--stats-test-map stats))) + (flet ((update (d) + (if (ert-test-result-expected-p (aref tests pos) + (aref results pos)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-expected stats) d)) + (ert-test-failed (incf (ert--stats-failed-expected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) + (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit))))) + ;; Adjust counters to remove the result that is currently in stats. + (update -1) + ;; Put new test and result into stats. + (setf (aref tests pos) test + (aref results pos) result) + (remhash (ert--stats-test-key old-test) map) + (setf (gethash (ert--stats-test-key test) map) pos) + ;; Adjust counters to match new result. + (update +1) + nil))) + +(defun ert--make-stats (tests selector) + "Create a new `ert--stats' object for running TESTS. + +SELECTOR is the selector that was used to select TESTS." + (setq tests (ert--coerce-to-vector tests)) + (let ((map (make-hash-table :size (length tests)))) + (loop for i from 0 + for test across tests + for key = (ert--stats-test-key test) do + (assert (not (gethash key map))) + (setf (gethash key map) i)) + (make-ert--stats :selector selector + :tests tests + :test-map map + :test-results (make-vector (length tests) nil) + :test-start-times (make-vector (length tests) nil) + :test-end-times (make-vector (length tests) nil)))) + +(defun ert-run-or-rerun-test (stats test listener) + ;; checkdoc-order: nil + "Run the single test TEST and record the result using STATS and LISTENER." + (let ((ert--current-run-stats stats) + (pos (ert--stats-test-pos stats test))) + (ert--stats-set-test-and-result stats pos test nil) + ;; Call listener after setting/before resetting + ;; (ert--stats-current-test stats); the listener might refresh the + ;; mode line display, and if the value is not set yet/any more + ;; during this refresh, the mode line will flicker unnecessarily. + (setf (ert--stats-current-test stats) test) + (funcall listener 'test-started stats test) + (setf (ert-test-most-recent-result test) nil) + (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) + (unwind-protect + (ert-run-test test) + (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) + (let ((result (ert-test-most-recent-result test))) + (ert--stats-set-test-and-result stats pos test result) + (funcall listener 'test-ended stats test result)) + (setf (ert--stats-current-test stats) nil)))) + +(defun ert-run-tests (selector listener) + "Run the tests specified by SELECTOR, sending progress updates to LISTENER." + (let* ((tests (ert-select-tests selector t)) + (stats (ert--make-stats tests selector))) + (setf (ert--stats-start-time stats) (current-time)) + (funcall listener 'run-started stats) + (let ((abortedp t)) + (unwind-protect + (let ((ert--current-run-stats stats)) + (force-mode-line-update) + (unwind-protect + (progn + (loop for test in tests do + (ert-run-or-rerun-test stats test listener)) + (setq abortedp nil)) + (setf (ert--stats-aborted-p stats) abortedp) + (setf (ert--stats-end-time stats) (current-time)) + (funcall listener 'run-ended stats abortedp))) + (force-mode-line-update)) + stats))) + +(defun ert--stats-test-pos (stats test) + ;; checkdoc-order: nil + "Return the position (index) of TEST in the run represented by STATS." + (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) + + +;;; Formatting functions shared across UIs. + +(defun ert--format-time-iso8601 (time) + "Format TIME in the variant of ISO 8601 used for timestamps in ERT." + (format-time-string "%Y-%m-%d %T%z" time)) + +(defun ert-char-for-test-result (result expectedp) + "Return a character that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed ".P") + (ert-test-failed "fF") + (null "--") + (ert-test-aborted-with-non-local-exit "aA") + (ert-test-quit "qQ")))) + (elt s (if expectedp 0 1)))) + +(defun ert-string-for-test-result (result expectedp) + "Return a string that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed '("passed" "PASSED")) + (ert-test-failed '("failed" "FAILED")) + (null '("unknown" "UNKNOWN")) + (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")) + (ert-test-quit '("quit" "QUIT"))))) + (elt s (if expectedp 0 1)))) + +(defun ert--pp-with-indentation-and-newline (object) + "Pretty-print OBJECT, indenting it to the current column of point. +Ensures a final newline is inserted." + (let ((begin (point))) + (pp object (current-buffer)) + (unless (bolp) (insert "\n")) + (save-excursion + (goto-char begin) + (indent-sexp)))) + +(defun ert--insert-infos (result) + "Insert `ert-info' infos from RESULT into current buffer. + +RESULT must be an `ert-test-result-with-condition'." + (check-type result ert-test-result-with-condition) + (dolist (info (ert-test-result-with-condition-infos result)) + (destructuring-bind (prefix . message) info + (let ((begin (point)) + (indentation (make-string (+ (length prefix) 4) ?\s)) + (end nil)) + (unwind-protect + (progn + (insert message "\n") + (setq end (copy-marker (point))) + (goto-char begin) + (insert " " prefix) + (forward-line 1) + (while (< (point) end) + (insert indentation) + (forward-line 1))) + (when end (set-marker end nil))))))) + + +;;; Running tests in batch mode. + +(defvar ert-batch-backtrace-right-margin 70 + "The maximum line length for printing backtraces in `ert-run-tests-batch'.") + +;;;###autoload +(defun ert-run-tests-batch (&optional selector) + "Run the tests specified by SELECTOR, printing results to the terminal. + +SELECTOR works as described in `ert-select-tests', except if +SELECTOR is nil, in which case all tests rather than none will be +run; this makes the command line \"emacs -batch -l my-tests.el -f +ert-run-tests-batch-and-exit\" useful. + +Returns the stats object." + (unless selector (setq selector 't)) + (ert-run-tests + selector + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (message "Running %s tests (%s)" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats))))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (let ((unexpected (ert-stats-completed-unexpected stats)) + (expected-failures (ert--stats-failed-expected stats))) + (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)) + (ert--format-time-iso8601 (ert--stats-end-time stats)) + (if (zerop expected-failures) + "" + (format "\n%s expected failures" expected-failures))) + (unless (zerop unexpected) + (message "%s unexpected results:" unexpected) + (loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (not (ert-test-result-expected-p test result)) + (message "%9s %S" + (ert-string-for-test-result result nil) + (ert-test-name test)))) + (message "%s" ""))))) + (test-started + ) + (test-ended + (destructuring-bind (stats test result) event-args + (unless (ert-test-result-expected-p test result) + (etypecase result + (ert-test-passed + (message "Test %S passed unexpectedly" (ert-test-name test))) + (ert-test-result-with-condition + (message "Test %S backtrace:" (ert-test-name test)) + (with-temp-buffer + (ert--print-backtrace (ert-test-result-with-condition-backtrace + result)) + (goto-char (point-min)) + (while (not (eobp)) + (let ((start (point)) + (end (progn (end-of-line) (point)))) + (setq end (min end + (+ start ert-batch-backtrace-right-margin))) + (message "%s" (buffer-substring-no-properties + start end))) + (forward-line 1))) + (with-temp-buffer + (ert--insert-infos result) + (insert " ") + (let ((print-escape-newlines t) + (print-level 5) + (print-length 10)) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result))) + (goto-char (1- (point-max))) + (assert (looking-at "\n")) + (delete-char 1) + (message "Test %S condition:" (ert-test-name test)) + (message "%s" (buffer-string)))) + (ert-test-aborted-with-non-local-exit + (message "Test %S aborted with non-local exit" + (ert-test-name test))) + (ert-test-quit + (message "Quit during %S" (ert-test-name test))))) + (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) + (format-string (concat "%9s %" + (prin1-to-string (length max)) + "s/" max " %S"))) + (message format-string + (ert-string-for-test-result result + (ert-test-result-expected-p + test result)) + (1+ (ert--stats-test-pos stats test)) + (ert-test-name test))))))))) + +;;;###autoload +(defun ert-run-tests-batch-and-exit (&optional selector) + "Like `ert-run-tests-batch', but exits Emacs when done. + +The exit status will be 0 if all test results were as expected, 1 +on unexpected results, or 2 if the tool detected an error outside +of the tests (e.g. invalid SELECTOR or bug in the code that runs +the tests)." + (unwind-protect + (let ((stats (ert-run-tests-batch selector))) + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (kill-emacs 2)))) + + +;;; Utility functions for load/unload actions. + +(defun ert--activate-font-lock-keywords () + "Activate font-lock keywords for some of ERT's symbols." + (font-lock-add-keywords + nil + '(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\sw+\\)?" + (1 font-lock-keyword-face nil t) + (2 font-lock-function-name-face nil t))))) + +(defun* ert--remove-from-list (list-var element &key key test) + "Remove ELEMENT from the value of LIST-VAR if present. + +This can be used as an inverse of `add-to-list'." + (unless key (setq key #'identity)) + (unless test (setq test #'equal)) + (setf (symbol-value list-var) + (ert--remove* element + (symbol-value list-var) + :key key + :test test))) + + +;;; Some basic interactive functions. + +(defun ert-read-test-name (prompt &optional default history + add-default-to-prompt) + "Read the name of a test and return it as a symbol. + +Prompt with PROMPT. If DEFAULT is a valid test name, use it as a +default. HISTORY is the history to use; see `completing-read'. +If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to +include the default, if any. + +Signals an error if no test name was read." + (etypecase default + (string (let ((symbol (intern-soft default))) + (unless (and symbol (ert-test-boundp symbol)) + (setq default nil)))) + (symbol (setq default + (if (ert-test-boundp default) + (symbol-name default) + nil))) + (ert-test (setq default (ert-test-name default)))) + (when add-default-to-prompt + (setq prompt (if (null default) + (format "%s: " prompt) + (format "%s (default %s): " prompt default)))) + (let ((input (completing-read prompt obarray #'ert-test-boundp + t nil history default nil))) + ;; completing-read returns an empty string if default was nil and + ;; the user just hit enter. + (let ((sym (intern-soft input))) + (if (ert-test-boundp sym) + sym + (error "Input does not name a test"))))) + +(defun ert-read-test-name-at-point (prompt) + "Read the name of a test and return it as a symbol. +As a default, use the symbol at point, or the test at point if in +the ERT results buffer. Prompt with PROMPT, augmented with the +default (if any)." + (ert-read-test-name prompt (ert-test-at-point) nil t)) + +(defun ert-find-test-other-window (test-name) + "Find, in another window, the definition of TEST-NAME." + (interactive (list (ert-read-test-name-at-point "Find test definition: "))) + (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) + +(defun ert-delete-test (test-name) + "Make the test TEST-NAME unbound. + +Nothing more than an interactive interface to `ert-make-test-unbound'." + (interactive (list (ert-read-test-name-at-point "Delete test"))) + (ert-make-test-unbound test-name)) + +(defun ert-delete-all-tests () + "Make all symbols in `obarray' name no test." + (interactive) + (when (called-interactively-p 'any) + (unless (y-or-n-p "Delete all tests? ") + (error "Aborted"))) + ;; We can't use `ert-select-tests' here since that gives us only + ;; test objects, and going from them back to the test name symbols + ;; can fail if the `ert-test' defstruct has been redefined. + (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) + t) + + +;;; Display of test progress and results. + +;; An entry in the results buffer ewoc. There is one entry per test. +(defstruct ert--ewoc-entry + (test (assert nil)) + ;; If the result of this test was expected, its ewoc entry is hidden + ;; initially. + (hidden-p (assert nil)) + ;; An ewoc entry may be collapsed to hide details such as the error + ;; condition. + ;; + ;; I'm not sure the ability to expand and collapse entries is still + ;; a useful feature. + (expanded-p t) + ;; By default, the ewoc entry presents the error condition with + ;; certain limits on how much to print (`print-level', + ;; `print-length'). The user can interactively switch to a set of + ;; higher limits. + (extended-printer-limits-p nil)) + +;; Variables local to the results buffer. + +;; The ewoc. +(defvar ert--results-ewoc) +;; The stats object. +(defvar ert--results-stats) +;; A string with one character per test. Each character represents +;; the result of the corresponding test. The string is displayed near +;; the top of the buffer and serves as a progress bar. +(defvar ert--results-progress-bar-string) +;; The position where the progress bar button begins. +(defvar ert--results-progress-bar-button-begin) +;; The test result listener that updates the buffer when tests are run. +(defvar ert--results-listener) + +(defun ert-insert-test-name-button (test-name) + "Insert a button that links to TEST-NAME." + (insert-text-button (format "%S" test-name) + :type 'ert--test-name-button + 'ert-test-name test-name)) + +(defun ert--results-format-expected-unexpected (expected unexpected) + "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." + (if (zerop unexpected) + (format "%s" expected) + (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) + +(defun ert--results-update-ewoc-hf (ewoc stats) + "Update the header and footer of EWOC to show certain information from STATS. + +Also sets `ert--results-progress-bar-button-begin'." + (let ((run-count (ert-stats-completed stats)) + (results-buffer (current-buffer)) + ;; Need to save buffer-local value. + (font-lock font-lock-mode)) + (ewoc-set-hf + ewoc + ;; header + (with-temp-buffer + (insert "Selector: ") + (ert--insert-human-readable-selector (ert--stats-selector stats)) + (insert "\n") + (insert + (format (concat "Passed: %s\n" + "Failed: %s\n" + "Total: %s/%s\n\n") + (ert--results-format-expected-unexpected + (ert--stats-passed-expected stats) + (ert--stats-passed-unexpected stats)) + (ert--results-format-expected-unexpected + (ert--stats-failed-expected stats) + (ert--stats-failed-unexpected stats)) + run-count + (ert-stats-total stats))) + (insert + (format "Started at: %s\n" + (ert--format-time-iso8601 (ert--stats-start-time stats)))) + ;; FIXME: This is ugly. Need to properly define invariants of + ;; the `stats' data structure. + (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) + ((ert--stats-current-test stats) 'running) + ((ert--stats-end-time stats) 'finished) + (t 'preparing)))) + (ecase state + (preparing + (insert "")) + (aborted + (cond ((ert--stats-current-test stats) + (insert "Aborted during test: ") + (ert-insert-test-name-button + (ert-test-name (ert--stats-current-test stats)))) + (t + (insert "Aborted.")))) + (running + (assert (ert--stats-current-test stats)) + (insert "Running test: ") + (ert-insert-test-name-button (ert-test-name + (ert--stats-current-test stats)))) + (finished + (assert (not (ert--stats-current-test stats))) + (insert "Finished."))) + (insert "\n") + (if (ert--stats-end-time stats) + (insert + (format "%s%s\n" + (if (ert--stats-aborted-p stats) + "Aborted at: " + "Finished at: ") + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + (insert "\n")) + (insert "\n")) + (let ((progress-bar-string (with-current-buffer results-buffer + ert--results-progress-bar-string))) + (let ((progress-bar-button-begin + (insert-text-button progress-bar-string + :type 'ert--results-progress-bar-button + 'face (or (and font-lock + (ert-face-for-stats stats)) + 'button)))) + ;; The header gets copied verbatim to the results buffer, + ;; and all positions remain the same, so + ;; `progress-bar-button-begin' will be the right position + ;; even in the results buffer. + (with-current-buffer results-buffer + (set (make-local-variable 'ert--results-progress-bar-button-begin) + progress-bar-button-begin)))) + (insert "\n\n") + (buffer-string)) + ;; footer + ;; + ;; We actually want an empty footer, but that would trigger a bug + ;; in ewoc, sometimes clearing the entire buffer. (It's possible + ;; that this bug has been fixed since this has been tested; we + ;; should test it again.) + "\n"))) + + +(defvar ert-test-run-redisplay-interval-secs .1 + "How many seconds ERT should wait between redisplays while running tests. + +While running tests, ERT shows the current progress, and this variable +determines how frequently the progress display is updated.") + +(defun ert--results-update-stats-display (ewoc stats) + "Update EWOC and the mode line to show data from STATS." + ;; TODO(ohler): investigate using `make-progress-reporter'. + (ert--results-update-ewoc-hf ewoc stats) + (force-mode-line-update) + (redisplay t) + (setf (ert--stats-next-redisplay stats) + (+ (float-time) ert-test-run-redisplay-interval-secs))) + +(defun ert--results-update-stats-display-maybe (ewoc stats) + "Call `ert--results-update-stats-display' if not called recently. + +EWOC and STATS are arguments for `ert--results-update-stats-display'." + (when (>= (float-time) (ert--stats-next-redisplay stats)) + (ert--results-update-stats-display ewoc stats))) + +(defun ert--tests-running-mode-line-indicator () + "Return a string for the mode line that shows the test run progress." + (let* ((stats ert--current-run-stats) + (tests-total (ert-stats-total stats)) + (tests-completed (ert-stats-completed stats))) + (if (>= tests-completed tests-total) + (format " ERT(%s/%s,finished)" tests-completed tests-total) + (format " ERT(%s/%s):%s" + (1+ tests-completed) + tests-total + (if (null (ert--stats-current-test stats)) + "?" + (format "%S" + (ert-test-name (ert--stats-current-test stats)))))))) + +(defun ert--make-xrefs-region (begin end) + "Attach cross-references to function names between BEGIN and END. + +BEGIN and END specify a region in the current buffer." + (save-excursion + (save-restriction + (narrow-to-region begin end) + ;; Inhibit optimization in `debugger-make-xrefs' that would + ;; sometimes insert unrelated backtrace info into our buffer. + (let ((debugger-previous-backtrace nil)) + (debugger-make-xrefs))))) + +(defun ert--string-first-line (s) + "Return the first line of S, or S if it contains no newlines. + +The return value does not include the line terminator." + (substring s 0 (ert--string-position ?\n s))) + +(defun ert-face-for-test-result (expectedp) + "Return a face that shows whether a test result was expected or unexpected. + +If EXPECTEDP is nil, returns the face for unexpected results; if +non-nil, returns the face for expected results.." + (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) + +(defun ert-face-for-stats (stats) + "Return a face that represents STATS." + (cond ((ert--stats-aborted-p stats) 'nil) + ((plusp (ert-stats-completed-unexpected stats)) + (ert-face-for-test-result nil)) + ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) + (ert-face-for-test-result t)) + (t 'nil))) + +(defun ert--print-test-for-ewoc (entry) + "The ewoc print function for ewoc test entries. ENTRY is the entry to print." + (let* ((test (ert--ewoc-entry-test entry)) + (stats ert--results-stats) + (result (let ((pos (ert--stats-test-pos stats test))) + (assert pos) + (aref (ert--stats-test-results stats) pos))) + (hiddenp (ert--ewoc-entry-hidden-p entry)) + (expandedp (ert--ewoc-entry-expanded-p entry)) + (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p + entry))) + (cond (hiddenp) + (t + (let ((expectedp (ert-test-result-expected-p test result))) + (insert-text-button (format "%c" (ert-char-for-test-result + result expectedp)) + :type 'ert--results-expand-collapse-button + 'face (or (and font-lock-mode + (ert-face-for-test-result + expectedp)) + 'button))) + (insert " ") + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n") + (when (and expandedp (not (eql result 'nil))) + (when (ert-test-documentation test) + (insert " " + (propertize + (ert--string-first-line (ert-test-documentation test)) + 'font-lock-face 'font-lock-doc-face) + "\n")) + (etypecase result + (ert-test-passed + (if (ert-test-result-expected-p test result) + (insert " passed\n") + (insert " passed unexpectedly\n")) + (insert "")) + (ert-test-result-with-condition + (ert--insert-infos result) + (let ((print-escape-newlines t) + (print-level (if extended-printer-limits-p 12 6)) + (print-length (if extended-printer-limits-p 100 10))) + (insert " ") + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)) + (ert--make-xrefs-region begin (point))))) + (ert-test-aborted-with-non-local-exit + (insert " aborted\n")) + (ert-test-quit + (insert " quit\n"))) + (insert "\n"))))) + nil) + +(defun ert--results-font-lock-function (enabledp) + "Redraw the ERT results buffer after font-lock-mode was switched on or off. + +ENABLEDP is true if font-lock-mode is switched on, false +otherwise." + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (ewoc-refresh ert--results-ewoc) + (font-lock-default-function enabledp)) + +(defun ert--setup-results-buffer (stats listener buffer-name) + "Set up a test results buffer. + +STATS is the stats object; LISTENER is the results listener; +BUFFER-NAME, if non-nil, is the buffer name to use." + (unless buffer-name (setq buffer-name "*ert*")) + (let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-results-mode) + ;; Erase buffer again in case switching out of the previous + ;; mode inserted anything. (This happens e.g. when switching + ;; from ert-results-mode to ert-results-mode when + ;; font-lock-mode turns itself off in change-major-mode-hook.) + (erase-buffer) + (set (make-local-variable 'font-lock-function) + 'ert--results-font-lock-function) + (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) + (set (make-local-variable 'ert--results-ewoc) ewoc) + (set (make-local-variable 'ert--results-stats) stats) + (set (make-local-variable 'ert--results-progress-bar-string) + (make-string (ert-stats-total stats) + (ert-char-for-test-result nil t))) + (set (make-local-variable 'ert--results-listener) listener) + (loop for test across (ert--stats-tests stats) do + (ewoc-enter-last ewoc + (make-ert--ewoc-entry :test test :hidden-p t))) + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (goto-char (1- (point-max))) + buffer))))) + + +(defvar ert--selector-history nil + "List of recent test selectors read from terminal.") + +;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? +;; They are needed only for our automated self-tests at the moment. +;; Or should there be some other mechanism? +;;;###autoload +(defun ert-run-tests-interactively (selector + &optional output-buffer-name message-fn) + "Run the tests specified by SELECTOR and display the results in a buffer. + +SELECTOR works as described in `ert-select-tests'. +OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they +are used for automated self-tests and specify which buffer to use +and how to display message." + (interactive + (list (let ((default (if ert--selector-history + ;; Can't use `first' here as this form is + ;; not compiled, and `first' is not + ;; defined without cl. + (car ert--selector-history) + "t"))) + (read-from-minibuffer (if (null default) + "Run tests: " + (format "Run tests (default %s): " default)) + nil nil t 'ert--selector-history + default nil)) + nil)) + (unless message-fn (setq message-fn 'message)) + (lexical-let ((output-buffer-name output-buffer-name) + buffer + listener + (message-fn message-fn)) + (setq listener + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (setq buffer (ert--setup-results-buffer stats + listener + output-buffer-name)) + (pop-to-buffer buffer))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (funcall message-fn + "%sRan %s tests, %s results were as expected%s" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (let ((unexpected + (ert-stats-completed-unexpected stats))) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)))) + (ert--results-update-stats-display (with-current-buffer buffer + ert--results-ewoc) + stats))) + (test-started + (destructuring-bind (stats test) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (assert node) + (setf (ert--ewoc-entry-test (ewoc-data node)) test) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result nil t)) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node))))) + (test-ended + (destructuring-bind (stats test result) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (when (ert--ewoc-entry-hidden-p (ewoc-data node)) + (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) + (ert-test-result-expected-p test result))) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result result + (ert-test-result-expected-p + test result))) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node)))))))) + (ert-run-tests + selector + listener))) +;;;###autoload +(defalias 'ert 'ert-run-tests-interactively) + + +;;; Simple view mode for auxiliary information like stack traces or +;;; messages. Mainly binds "q" for quit. + +(define-derived-mode ert-simple-view-mode special-mode "ERT-View" + "Major mode for viewing auxiliary information in ERT.") + +;;; Commands and button actions for the results buffer. + +(define-derived-mode ert-results-mode special-mode "ERT-Results" + "Major mode for viewing results of ERT test runs.") + +(loop for (key binding) in + '(;; Stuff that's not in the menu. + ("\t" forward-button) + ([backtab] backward-button) + ("j" ert-results-jump-between-summary-and-result) + ("L" ert-results-toggle-printer-limits-for-test-at-point) + ("n" ert-results-next-test) + ("p" ert-results-previous-test) + ;; Stuff that is in the menu. + ("R" ert-results-rerun-all-tests) + ("r" ert-results-rerun-test-at-point) + ("d" ert-results-rerun-test-at-point-debugging-errors) + ("." ert-results-find-test-at-point-other-window) + ("b" ert-results-pop-to-backtrace-for-test-at-point) + ("m" ert-results-pop-to-messages-for-test-at-point) + ("l" ert-results-pop-to-should-forms-for-test-at-point) + ("h" ert-results-describe-test-at-point) + ("D" ert-delete-test) + ("T" ert-results-pop-to-timings) + ) + do + (define-key ert-results-mode-map key binding)) + +(easy-menu-define ert-results-mode-menu ert-results-mode-map + "Menu for `ert-results-mode'." + '("ERT Results" + ["Re-run all tests" ert-results-rerun-all-tests] + "--" + ["Re-run test" ert-results-rerun-test-at-point] + ["Debug test" ert-results-rerun-test-at-point-debugging-errors] + ["Show test definition" ert-results-find-test-at-point-other-window] + "--" + ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] + ["Show messages" ert-results-pop-to-messages-for-test-at-point] + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] + ["Describe test" ert-results-describe-test-at-point] + "--" + ["Delete test" ert-delete-test] + "--" + ["Show execution time of each test" ert-results-pop-to-timings] + )) + +(define-button-type 'ert--results-progress-bar-button + 'action #'ert--results-progress-bar-button-action + 'help-echo "mouse-2, RET: Reveal test result") + +(define-button-type 'ert--test-name-button + 'action #'ert--test-name-button-action + 'help-echo "mouse-2, RET: Find test definition") + +(define-button-type 'ert--results-expand-collapse-button + 'action #'ert--results-expand-collapse-button-action + 'help-echo "mouse-2, RET: Expand/collapse test result") + +(defun ert--results-test-node-or-null-at-point () + "If point is on a valid ewoc node, return it; return nil otherwise. + +To be used in the ERT results buffer." + (let* ((ewoc ert--results-ewoc) + (node (ewoc-locate ewoc))) + ;; `ewoc-locate' will return an arbitrary node when point is on + ;; header or footer, or when all nodes are invisible. So we need + ;; to validate its return value here. + ;; + ;; Update: I'm seeing nil being returned in some cases now, + ;; perhaps this has been changed? + (if (and node + (>= (point) (ewoc-location node)) + (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) + node + nil))) + +(defun ert--results-test-node-at-point () + "If point is on a valid ewoc node, return it; signal an error otherwise. + +To be used in the ERT results buffer." + (or (ert--results-test-node-or-null-at-point) + (error "No test at point"))) + +(defun ert-results-next-test () + "Move point to the next test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next + "No tests below")) + +(defun ert-results-previous-test () + "Move point to the previous test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev + "No tests above")) + +(defun ert--results-move (node ewoc-fn error-message) + "Move point from NODE to the previous or next node. + +EWOC-FN specifies the direction and should be either `ewoc-prev' +or `ewoc-next'. If there are no more nodes in that direction, an +error is signaled with the message ERROR-MESSAGE." + (loop + (setq node (funcall ewoc-fn ert--results-ewoc node)) + (when (null node) + (error "%s" error-message)) + (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) + (goto-char (ewoc-location node)) + (return)))) + +(defun ert--results-expand-collapse-button-action (button) + "Expand or collapse the test node BUTTON belongs to." + (let* ((ewoc ert--results-ewoc) + (node (save-excursion + (goto-char (ert--button-action-position)) + (ert--results-test-node-at-point))) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-expanded-p entry) + (not (ert--ewoc-entry-expanded-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-find-test-at-point-other-window () + "Find the definition of the test at point in another window. + +To be used in the ERT results buffer." + (interactive) + (let ((name (ert-test-at-point))) + (unless name + (error "No test at point")) + (ert-find-test-other-window name))) + +(defun ert--test-name-button-action (button) + "Find the definition of the test BUTTON belongs to, in another window." + (let ((name (button-get button 'ert-test-name))) + (ert-find-test-other-window name))) + +(defun ert--ewoc-position (ewoc node) + ;; checkdoc-order: nil + "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." + (loop for i from 0 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) + do (when (eql node node-here) + (return i)) + finally (return nil))) + +(defun ert-results-jump-between-summary-and-result () + "Jump back and forth between the test run summary and individual test results. + +From an ewoc node, jumps to the character that represents the +same test in the progress bar, and vice versa. + +To be used in the ERT results buffer." + ;; Maybe this command isn't actually needed much, but if it is, it + ;; seems like an indication that the UI design is not optimal. If + ;; jumping back and forth between a summary at the top of the buffer + ;; and the error log in the remainder of the buffer is useful, then + ;; the summary apparently needs to be easily accessible from the + ;; error log, and perhaps it would be better to have it in a + ;; separate buffer to keep it visible. + (interactive) + (let ((ewoc ert--results-ewoc) + (progress-bar-begin ert--results-progress-bar-button-begin)) + (cond ((ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (pos (ert--ewoc-position ewoc node))) + (goto-char (+ progress-bar-begin pos)))) + ((and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) + (entry (ewoc-data node))) + (when (ert--ewoc-entry-hidden-p entry) + (setf (ert--ewoc-entry-hidden-p entry) nil) + (ewoc-invalidate ewoc node)) + (ewoc-goto-node ewoc node))) + (t + (goto-char progress-bar-begin))))) + +(defun ert-test-at-point () + "Return the name of the test at point as a symbol, or nil if none." + (or (and (eql major-mode 'ert-results-mode) + (let ((test (ert--results-test-at-point-no-redefinition))) + (and test (ert-test-name test)))) + (let* ((thing (thing-at-point 'symbol)) + (sym (intern-soft thing))) + (and (ert-test-boundp sym) + sym)))) + +(defun ert--results-test-at-point-no-redefinition () + "Return the test at point, or nil. + +To be used in the ERT results buffer." + (assert (eql major-mode 'ert-results-mode)) + (if (ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (test (ert--ewoc-entry-test (ewoc-data node)))) + test) + (let ((progress-bar-begin ert--results-progress-bar-button-begin)) + (when (and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((test-index (- (point) progress-bar-begin)) + (test (aref (ert--stats-tests ert--results-stats) + test-index))) + test))))) + +(defun ert--results-test-at-point-allow-redefinition () + "Look up the test at point, and check whether it has been redefined. + +To be used in the ERT results buffer. + +Returns a list of two elements: the test (or nil) and a symbol +specifying whether the test has been redefined. + +If a new test has been defined with the same name as the test at +point, replaces the test at point with the new test, and returns +the new test and the symbol `redefined'. + +If the test has been deleted, returns the old test and the symbol +`deleted'. + +If the test is still current, returns the test and the symbol nil. + +If there is no test at point, returns a list with two nils." + (let ((test (ert--results-test-at-point-no-redefinition))) + (cond ((null test) + `(nil nil)) + ((null (ert-test-name test)) + `(,test nil)) + (t + (let* ((name (ert-test-name test)) + (new-test (and (ert-test-boundp name) + (ert-get-test name)))) + (cond ((eql test new-test) + `(,test nil)) + ((null new-test) + `(,test deleted)) + (t + (ert--results-update-after-test-redefinition + (ert--stats-test-pos ert--results-stats test) + new-test) + `(,new-test redefined)))))))) + +(defun ert--results-update-after-test-redefinition (pos new-test) + "Update results buffer after the test at pos POS has been redefined. + +Also updates the stats object. NEW-TEST is the new test +definition." + (let* ((stats ert--results-stats) + (ewoc ert--results-ewoc) + (node (ewoc-nth ewoc pos)) + (entry (ewoc-data node))) + (ert--stats-set-test-and-result stats pos new-test nil) + (setf (ert--ewoc-entry-test entry) new-test + (aref ert--results-progress-bar-string pos) (ert-char-for-test-result + nil t)) + (ewoc-invalidate ewoc node)) + nil) + +(defun ert--button-action-position () + "The buffer position where the last button action was triggered." + (cond ((integerp last-command-event) + (point)) + ((eventp last-command-event) + (posn-point (event-start last-command-event))) + (t (assert nil)))) + +(defun ert--results-progress-bar-button-action (button) + "Jump to details for the test represented by the character clicked in BUTTON." + (goto-char (ert--button-action-position)) + (ert-results-jump-between-summary-and-result)) + +(defun ert-results-rerun-all-tests () + "Re-run all tests, using the same selector. + +To be used in the ERT results buffer." + (interactive) + (assert (eql major-mode 'ert-results-mode)) + (let ((selector (ert--stats-selector ert--results-stats))) + (ert-run-tests-interactively selector (buffer-name)))) + +(defun ert-results-rerun-test-at-point () + "Re-run the test at point. + +To be used in the ERT results buffer." + (interactive) + (destructuring-bind (test redefinition-state) + (ert--results-test-at-point-allow-redefinition) + (when (null test) + (error "No test at point")) + (let* ((stats ert--results-stats) + (progress-message (format "Running %stest %S" + (ecase redefinition-state + ((nil) "") + (redefined "new definition of ") + (deleted "deleted ")) + (ert-test-name test)))) + ;; Need to save and restore point manually here: When point is on + ;; the first visible ewoc entry while the header is updated, point + ;; moves to the top of the buffer. This is undesirable, and a + ;; simple `save-excursion' doesn't prevent it. + (let ((point (point))) + (unwind-protect + (unwind-protect + (progn + (message "%s..." progress-message) + (ert-run-or-rerun-test stats test + ert--results-listener)) + (ert--results-update-stats-display ert--results-ewoc stats) + (message "%s...%s" + progress-message + (let ((result (ert-test-most-recent-result test))) + (ert-string-for-test-result + result (ert-test-result-expected-p test result))))) + (goto-char point)))))) + +(defun ert-results-rerun-test-at-point-debugging-errors () + "Re-run the test at point with `ert-debug-on-error' bound to t. + +To be used in the ERT results buffer." + (interactive) + (let ((ert-debug-on-error t)) + (ert-results-rerun-test-at-point))) + +(defun ert-results-pop-to-backtrace-for-test-at-point () + "Display the backtrace for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (etypecase result + (ert-test-passed (error "Test passed, no backtrace available")) + (ert-test-result-with-condition + (let ((backtrace (ert-test-result-with-condition-backtrace result)) + (buffer (get-buffer-create "*ERT Backtrace*"))) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + ;; Use unibyte because `debugger-setup-buffer' also does so. + (set-buffer-multibyte nil) + (setq truncate-lines t) + (ert--print-backtrace backtrace) + (debugger-make-xrefs) + (goto-char (point-min)) + (insert "Backtrace for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))))) + +(defun ert-results-pop-to-messages-for-test-at-point () + "Display the part of the *Messages* buffer generated during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT Messages*"))) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (insert (ert-test-result-messages result)) + (goto-char (point-min)) + (insert "Messages for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))) + +(defun ert-results-pop-to-should-forms-for-test-at-point () + "Display the list of `should' forms executed during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT list of should forms*"))) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null (ert-test-result-should-forms result)) + (insert "\n(No should forms during this test.)\n") + (loop for form-description in (ert-test-result-should-forms result) + for i from 1 do + (insert "\n") + (insert (format "%s: " i)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline form-description) + (ert--make-xrefs-region begin (point))))) + (goto-char (point-min)) + (insert "`should' forms executed during test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n") + (insert "\n") + (insert (concat "(Values are shallow copies and may have " + "looked different during the test if they\n" + "have been modified destructively.)\n")) + (forward-line 1))))) + +(defun ert-results-toggle-printer-limits-for-test-at-point () + "Toggle how much of the condition to print for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((ewoc ert--results-ewoc) + (node (ert--results-test-node-at-point)) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-extended-printer-limits-p entry) + (not (ert--ewoc-entry-extended-printer-limits-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-pop-to-timings () + "Display test timings for the last run. + +To be used in the ERT results buffer." + (interactive) + (let* ((stats ert--results-stats) + (start-times (ert--stats-test-start-times stats)) + (end-times (ert--stats-test-end-times stats)) + (buffer (get-buffer-create "*ERT timings*")) + (data (loop for test across (ert--stats-tests stats) + for start-time across (ert--stats-test-start-times stats) + for end-time across (ert--stats-test-end-times stats) + collect (list test + (float-time (subtract-time end-time + start-time)))))) + (setq data (sort data (lambda (a b) + (> (second a) (second b))))) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null data) + (insert "(No data)\n") + (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) + (loop for (test time) in data + for cumul-time = time then (+ cumul-time time) + for i from 1 do + (let ((begin (point))) + (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n")))) + (goto-char (point-min)) + (insert "Tests by run time (seconds):\n\n") + (forward-line 1)))) + +;;;###autoload +(defun ert-describe-test (test-or-test-name) + "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." + (interactive (list (ert-read-test-name-at-point "Describe test"))) + (when (< emacs-major-version 24) + (error "Requires Emacs 24")) + (let (test-name + test-definition) + (etypecase test-or-test-name + (symbol (setq test-name test-or-test-name + test-definition (ert-get-test test-or-test-name))) + (ert-test (setq test-name (ert-test-name test-or-test-name) + test-definition test-or-test-name))) + (help-setup-xref (list #'ert-describe-test test-or-test-name) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (insert (if test-name (format "%S" test-name) "<anonymous test>")) + (insert " is a test") + (let ((file-name (and test-name + (symbol-file test-name 'ert-deftest)))) + (when file-name + (insert " defined in `" (file-name-nondirectory file-name) "'") + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function-def test-name file-name))) + (insert ".") + (fill-region-as-paragraph (point-min) (point)) + (insert "\n\n") + (unless (and (ert-test-boundp test-name) + (eql (ert-get-test test-name) test-definition)) + (let ((begin (point))) + (insert "Note: This test has been redefined or deleted, " + "this documentation refers to an old definition.") + (fill-region-as-paragraph begin (point))) + (insert "\n\n")) + (insert (or (ert-test-documentation test-definition) + "It is not documented.") + "\n"))))))) + +(defun ert-results-describe-test-at-point () + "Display the documentation of the test at point. + +To be used in the ERT results buffer." + (interactive) + (ert-describe-test (ert--results-test-at-point-no-redefinition))) + + +;;; Actions on load/unload. + +(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) +(add-to-list 'minor-mode-alist '(ert--current-run-stats + (:eval + (ert--tests-running-mode-line-indicator)))) +(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) + +(defun ert--unload-function () + "Unload function to undo the side-effects of loading ert.el." + (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) + (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) + (ert--remove-from-list 'emacs-lisp-mode-hook + 'ert--activate-font-lock-keywords) + nil) + +(defvar ert-unload-hook '()) +(add-hook 'ert-unload-hook 'ert--unload-function) + + +(provide 'ert) + +;;; ert.el ends here diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index 432cf6a744e..ffd17e5d7af 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -1,7 +1,6 @@ -;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer +;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer -*- lexical-binding: t -*- -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1991-2013 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> ;; Inge Wallin <inge@lysator.liu.se> @@ -27,7 +26,7 @@ ;;; Commentary: ;; Ewoc Was Once Cookie -;; But now it's Emacs' Widget for Object Collections +;; But now it's Emacs's Widget for Object Collections ;; As the name implies this derives from the `cookie' package (part ;; of Elib). The changes are pervasive though mostly superficial: @@ -97,11 +96,11 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; The doubly linked list is implemented as a circular list with a dummy ;; node first and last. The dummy node is used as "the dll". -(defstruct (ewoc--node +(cl-defstruct (ewoc--node (:type vector) ;ewoc--node-nth needs this (:constructor nil) (:constructor ewoc--node-create (start-marker data))) @@ -141,7 +140,7 @@ and (ewoc--node-nth dll -1) returns the last node." ;;; The ewoc data type -(defstruct (ewoc +(cl-defstruct (ewoc (:constructor nil) (:constructor ewoc--create (buffer pretty-printer dll)) (:conc-name ewoc--)) @@ -217,10 +216,9 @@ NODE and leaving the new node's start there. Return the new node." (ewoc--adjust m (point) R dll))) (defun ewoc--wrap (func) - (lexical-let ((ewoc--user-pp func)) - (lambda (data) - (funcall ewoc--user-pp data) - (insert "\n")))) + (lambda (data) + (funcall func data) + (insert "\n"))) ;;; =========================================================================== @@ -496,6 +494,8 @@ Return the node (or nil if we just passed the last node)." ;; Never step below the first element. ;; (unless (ewoc--filter-hf-nodes ewoc node) ;; (setq node (ewoc--node-nth dll -2))) + (unless node + (error "No next")) (ewoc-goto-node ewoc node))) (defun ewoc-goto-node (ewoc node) @@ -578,5 +578,4 @@ Return nil if the buffer has been deleted." ;; eval: (put 'ewoc--set-buffer-bind-dll-let* 'lisp-indent-hook 2) ;; End: -;; arch-tag: d78915b9-9a07-44bf-aac6-04a1fc1bd6d4 ;;; ewoc.el ends here diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index fbea26c5c40..f06ad912bc8 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -1,7 +1,6 @@ ;;; find-func.el --- find the definition of the Emacs Lisp function near point -;; Copyright (C) 1997, 1999, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2013 Free Software Foundation, Inc. ;; Author: Jens Petersen <petersen@kurims.kyoto-u.ac.jp> ;; Maintainer: petersen@kurims.kyoto-u.ac.jp @@ -142,6 +141,15 @@ See the functions `find-function' and `find-variable'." (dolist (suffix (get-load-suffixes) (nreverse suffixes)) (unless (string-match "elc" suffix) (push suffix suffixes))))) +(defun find-library--load-name (library) + (let ((name library)) + (dolist (dir load-path) + (let ((rel (file-relative-name library dir))) + (if (and (not (string-match "\\`\\.\\./" rel)) + (< (length rel) (length name))) + (setq name rel)))) + (unless (equal name library) name))) + (defun find-library-name (library) "Return the absolute file name of the Emacs Lisp source of LIBRARY. LIBRARY should be a string (the name of the library)." @@ -149,13 +157,23 @@ LIBRARY should be a string (the name of the library)." ;; the same name. (if (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) - (or + (or (locate-file library (or find-function-source-path load-path) (find-library-suffixes)) (locate-file library (or find-function-source-path load-path) load-file-rep-suffixes) + (when (file-name-absolute-p library) + (let ((rel (find-library--load-name library))) + (when rel + (or + (locate-file rel + (or find-function-source-path load-path) + (find-library-suffixes)) + (locate-file rel + (or find-function-source-path load-path) + load-file-rep-suffixes))))) (error "Can't find library %s" library))) (defvar find-function-C-source-directory @@ -180,13 +198,14 @@ If FUNC is not the symbol of an advised function, just returns FUNC." (defun find-function-C-source (fun-or-var file type) "Find the source location where FUN-OR-VAR is defined in FILE. TYPE should be nil to find a function, or `defvar' to find a variable." - (unless find-function-C-source-directory - (setq find-function-C-source-directory - (read-directory-name "Emacs C source dir: " nil nil t))) - (setq file (expand-file-name file find-function-C-source-directory)) - (unless (file-readable-p file) - (error "The C source file %s is not available" - (file-name-nondirectory file))) + (let ((dir (or find-function-C-source-directory + (read-directory-name "Emacs C source dir: " nil nil t)))) + (setq file (expand-file-name file dir)) + (if (file-readable-p file) + (if (null find-function-C-source-directory) + (setq find-function-C-source-directory dir)) + (error "The C source file %s is not available" + (file-name-nondirectory file)))) (unless type ;; Either or both an alias and its target might be advised. (setq fun-or-var (find-function-advised-original @@ -213,6 +232,8 @@ LIBRARY should be a string (the name of the library)." (interactive (let* ((dirs (or find-function-source-path load-path)) (suffixes (find-library-suffixes)) + (table (apply-partially 'locate-file-completion-table + dirs suffixes)) (def (if (eq (function-called-at-point) 'require) ;; `function-called-at-point' may return 'require ;; with `point' anywhere on this line. So wrap the @@ -226,16 +247,12 @@ LIBRARY should be a string (the name of the library)." (thing-at-point 'symbol)) (error nil)) (thing-at-point 'symbol)))) - (when def - (setq def (and (locate-file-completion-table - dirs suffixes def nil 'lambda) - def))) + (when (and def (not (test-completion def table))) + (setq def nil)) (list (completing-read (if def (format "Library name (default %s): " def) "Library name: ") - (apply-partially 'locate-file-completion-table - dirs suffixes) - nil nil nil nil def)))) + table nil nil nil nil def)))) (let ((buf (find-file-noselect (find-library-name library)))) (condition-case nil (switch-to-buffer buf) (error (pop-to-buffer buf))))) @@ -296,7 +313,7 @@ The search is done in the source for library LIBRARY." (cons (current-buffer) nil)))))))) ;;;###autoload -(defun find-function-noselect (function) +(defun find-function-noselect (function &optional lisp-only) "Return a pair (BUFFER . POINT) pointing to the definition of FUNCTION. Finds the source file containing the definition of FUNCTION @@ -304,6 +321,10 @@ in a buffer and the point of the definition. The buffer is not selected. If the function definition can't be found in the buffer, returns (BUFFER). +If FUNCTION is a built-in function, this function normally +attempts to find it in the Emacs C sources; however, if LISP-ONLY +is non-nil, signal an error instead. + If the file where FUNCTION is defined is not known, then it is searched for in `find-function-source-path' if non-nil, otherwise in `load-path'." @@ -326,9 +347,10 @@ in `load-path'." (if aliases (message "%s" aliases)) (let ((library - (cond ((eq (car-safe def) 'autoload) - (nth 1 def)) + (cond ((autoloadp def) (nth 1 def)) ((subrp def) + (if lisp-only + (error "%s is a built-in function" function)) (help-C-file-name def 'subr)) ((symbol-file function 'defun))))) (find-function-search-for-symbol function nil library)))) @@ -340,29 +362,23 @@ If TYPE is nil, insist on a symbol with a function definition. Otherwise TYPE should be `defvar' or `defface'. If TYPE is nil, defaults using `function-called-at-point', otherwise uses `variable-at-point'." - (let ((symb (if (null type) - (function-called-at-point) - (if (eq type 'defvar) - (variable-at-point) - (variable-at-point t)))) - (predicate (cdr (assq type '((nil . fboundp) (defvar . boundp) - (defface . facep))))) - (prompt (cdr (assq type '((nil . "function") (defvar . "variable") - (defface . "face"))))) - (enable-recursive-minibuffers t) - val) - (if (equal symb 0) - (setq symb nil)) - (setq val (completing-read - (concat "Find " - prompt - (if symb - (format " (default %s)" symb)) - ": ") - obarray predicate t nil)) - (list (if (equal val "") - symb - (intern val))))) + (let* ((symb1 (cond ((null type) (function-called-at-point)) + ((eq type 'defvar) (variable-at-point)) + (t (variable-at-point t)))) + (symb (unless (eq symb1 0) symb1)) + (predicate (cdr (assq type '((nil . fboundp) + (defvar . boundp) + (defface . facep))))) + (prompt-type (cdr (assq type '((nil . "function") + (defvar . "variable") + (defface . "face"))))) + (prompt (concat "Find " prompt-type + (and symb (format " (default %s)" symb)) + ": ")) + (enable-recursive-minibuffers t)) + (list (intern (completing-read + prompt obarray predicate + t nil nil (and symb (symbol-name symb))))))) (defun find-function-do-it (symbol type switch-fn) "Find Emacs Lisp SYMBOL in a buffer and display it. @@ -565,5 +581,4 @@ Set mark before moving, if the buffer already existed." (provide 'find-func) -;; arch-tag: 43ecd81c-74dc-4d9a-8f63-a61e55670d64 ;;; find-func.el ends here diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el index 8eda7faf207..82b3e94bb4d 100644 --- a/lisp/emacs-lisp/find-gc.el +++ b/lisp/emacs-lisp/find-gc.el @@ -1,7 +1,6 @@ ;;; find-gc.el --- detect functions that call the garbage collector -;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2013 Free Software Foundation, Inc. ;; Maintainer: FSF @@ -56,11 +55,11 @@ Each entry has the form (FUNCTION . FUNCTIONS-IT-CALLS).") "term.c" "cm.c" "emacs.c" "keyboard.c" "macros.c" "keymap.c" "sysdep.c" "buffer.c" "filelock.c" "insdel.c" "marker.c" "minibuf.c" "fileio.c" - "dired.c" "filemode.c" "cmds.c" "casefiddle.c" + "dired.c" "cmds.c" "casefiddle.c" "indent.c" "search.c" "regex.c" "undo.c" "alloc.c" "data.c" "doc.c" "editfns.c" "callint.c" "eval.c" "fns.c" "print.c" "lread.c" - "abbrev.c" "syntax.c" "unexec.c" + "abbrev.c" "syntax.c" "unexcoff.c" "bytecode.c" "process.c" "callproc.c" "doprnt.c" "x11term.c" "x11fns.c")) @@ -159,5 +158,4 @@ Also store it in `find-gc-unsafe'." (provide 'find-gc) -;; arch-tag: 4a26a538-a008-40d9-a1ef-23bb6dbecef4 ;;; find-gc.el ends here diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index 5fa5b2431dd..6dee2cb48da 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -1,10 +1,10 @@ ;;; float-sup.el --- define some constants useful for floating point numbers. -;; Copyright (C) 1985, 1986, 1987, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1987, 2001-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -25,36 +25,29 @@ ;;; Code: -;; Provide a meaningful error message if we are running on -;; bare (non-float) emacs. - -(if (fboundp 'atan) - nil - (error "Floating point was disabled at compile time")) - -;; provide an easy hook to tell if we are running with floats or not. -;; define pi and e via math-lib calls. (much less prone to killer typos.) +;; Provide an easy hook to tell if we are running with floats or not. +;; Define pi and e via math-lib calls (much less prone to killer typos). (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).") -(defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.") +(defconst pi float-pi + "Obsolete since Emacs-23.3. Use `float-pi' instead.") +(internal-make-var-non-special 'pi) (defconst float-e (exp 1) "The value of e (2.7182818...).") -(defvar e float-e "Obsolete since Emacs-23.3. Use `float-e' instead.") (defconst degrees-to-radians (/ float-pi 180.0) "Degrees to radian conversion constant.") (defconst radians-to-degrees (/ 180.0 float-pi) "Radian to degree conversion constant.") -;; these expand to a single multiply by a float when byte compiled +;; These expand to a single multiply by a float when byte compiled. (defmacro degrees-to-radians (x) - "Convert ARG from degrees to radians." + "Convert X from degrees to radians." (list '* degrees-to-radians x)) (defmacro radians-to-degrees (x) - "Convert ARG from radians to degrees." + "Convert X from radians to degrees." (list '* radians-to-degrees x)) (provide 'lisp-float-type) -;; arch-tag: e7837072-a4af-4d08-9953-8a3e755abf9d ;;; float-sup.el ends here diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index bee0f99fec2..dd5ff0ec694 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -1,11 +1,11 @@ ;;; generic.el --- defining simple major modes with comment and font-lock ;; -;; Copyright (C) 1997, 1999, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2013 Free Software Foundation, Inc. ;; ;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Fri Sep 27 1996 ;; Keywords: generic, comment, font-lock +;; Package: emacs ;; This file is part of GNU Emacs. @@ -97,10 +97,11 @@ ;; Internal Variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-obsolete-variable-alias 'generic-font-lock-defaults + 'generic-font-lock-keywords "22.1") (defvar generic-font-lock-keywords nil "Keywords for `font-lock-defaults' in a generic mode.") (make-variable-buffer-local 'generic-font-lock-keywords) -(define-obsolete-variable-alias 'generic-font-lock-defaults 'generic-font-lock-keywords "22.1") ;;;###autoload (defvar generic-mode-list nil @@ -150,7 +151,8 @@ mode hook `MODE-hook'. See the file generic-x.el for some examples of `define-generic-mode'." (declare (debug (sexp def-form def-form def-form form def-form [&optional stringp] &rest [keywordp form])) - (indent 1)) + (indent 1) + (doc-string 7)) ;; Backward compatibility. (when (eq (car-safe mode) 'quote) @@ -315,5 +317,4 @@ regular expression that can be used as an element of (provide 'generic) -;; arch-tag: 239c1fc4-1303-48d9-9ac0-657d655669ea ;;; generic.el ends here diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el index e8e72798f8d..d3a43329366 100644 --- a/lisp/emacs-lisp/gulp.el +++ b/lisp/emacs-lisp/gulp.el @@ -1,7 +1,6 @@ ;;; gulp.el --- ask for updates for Lisp packages -;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1996, 2001-2013 Free Software Foundation, Inc. ;; Author: Sam Shteingold <shteingd@math.ucla.edu> ;; Maintainer: FSF @@ -175,5 +174,4 @@ That is a list of elements, each of the form (MAINTAINER PACKAGES...)." (provide 'gulp) -;; arch-tag: 42750a11-460a-4efc-829f-342d075530e5 ;;; gulp.el ends here diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el new file mode 100644 index 00000000000..e3e5b321047 --- /dev/null +++ b/lisp/emacs-lisp/gv.el @@ -0,0 +1,462 @@ +;;; gv.el --- generalized variables -*- lexical-binding: t -*- + +;; Copyright (C) 2012-2013 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: extensions +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This is a re-implementation of the setf machinery using a different +;; underlying approach than the one used earlier in CL, which was based on +;; define-setf-expander. +;; `define-setf-expander' makes every "place-expander" return a 5-tuple +;; (VARS VALUES STORES GETTER SETTER) +;; where STORES is a list with a single variable (Common-Lisp allows multiple +;; variables for use with multiple-return-values, but this is rarely used and +;; not applicable to Elisp). +;; It basically says that GETTER is an expression that returns the place's +;; value, and (lambda STORES SETTER) is an expression that assigns the value(s) +;; passed to that function to the place, and that you need to wrap the whole +;; thing within a `(let* ,(zip VARS VALUES) ...). +;; +;; Instead, we use here a higher-order approach: instead +;; of a 5-tuple, a place-expander returns a function. +;; If you think about types, the old approach return things of type +;; {vars: List Var, values: List Exp, +;; stores: List Var, getter: Exp, setter: Exp} +;; whereas the new approach returns a function of type +;; (do: ((getter: Exp, setter: ((store: Exp) -> Exp)) -> Exp)) -> Exp. +;; You can get the new function from the old 5-tuple with something like: +;; (lambda (do) +;; `(let* ,(zip VARS VALUES) +;; (funcall do GETTER (lambda ,STORES ,SETTER)))) +;; You can't easily do the reverse, because this new approach is more +;; expressive than the old one, so we can't provide a backward-compatible +;; get-setf-method. +;; +;; While it may seem intimidating for people not used to higher-order +;; functions, you will quickly see that its use (especially with the +;; `gv-letplace' macro) is actually much easier and more elegant than the old +;; approach which is clunky and often leads to unreadable code. + +;; Food for thought: the syntax of places does not actually conflict with the +;; pcase patterns. The `cons' gv works just like a `(,a . ,b) pcase +;; pattern, and actually the `logand' gv is even closer since it should +;; arguably fail when trying to set a value outside of the mask. +;; Generally, places are used for destructors (gethash, aref, car, ...) +;; whereas pcase patterns are used for constructors (backquote, constants, +;; vectors, ...). + +;;; Code: + +(require 'macroexp) + +;; What we call a "gvar" is basically a function of type "(getter * setter -> +;; code) -> code", where "getter" is code and setter is "code -> code". + +;; (defvar gv--macro-environment nil +;; "Macro expanders for generalized variables.") + +;;;###autoload +(defun gv-get (place do) + "Build the code that applies DO to PLACE. +PLACE must be a valid generalized variable. +DO must be a function; it will be called with 2 arguments: GETTER and SETTER, +where GETTER is a (copyable) Elisp expression that returns the value of PLACE, +and SETTER is a function which returns the code to set PLACE when called +with a (not necessarily copyable) Elisp expression that returns the value to +set it to. +DO must return an Elisp expression." + (if (symbolp place) + (funcall do place (lambda (v) `(setq ,place ,v))) + (let* ((head (car place)) + (gf (function-get head 'gv-expander 'autoload))) + (if gf (apply gf do (cdr place)) + (let ((me (macroexpand place ;FIXME: expand one step at a time! + ;; (append macroexpand-all-environment + ;; gv--macro-environment) + macroexpand-all-environment))) + (if (and (eq me place) (get head 'compiler-macro)) + ;; Expand compiler macros: this takes care of all the accessors + ;; defined via cl-defsubst, such as cXXXr and defstruct slots. + (setq me (apply (get head 'compiler-macro) place (cdr place)))) + (if (and (eq me place) (fboundp head) + (symbolp (symbol-function head))) + ;; Follow aliases. + (setq me (cons (symbol-function head) (cdr place)))) + (if (eq me place) + (error "%S is not a valid place expression" place) + (gv-get me do))))))) + +;;;###autoload +(defmacro gv-letplace (vars place &rest body) + "Build the code manipulating the generalized variable PLACE. +GETTER will be bound to a copyable expression that returns the value +of PLACE. +SETTER will be bound to a function that takes an expression V and returns +a new expression that sets PLACE to V. +BODY should return some Elisp expression E manipulating PLACE via GETTER +and SETTER. +The returned value will then be an Elisp expression that first evaluates +all the parts of PLACE that can be evaluated and then runs E. + +\(fn (GETTER SETTER) PLACE &rest BODY)" + (declare (indent 2) (debug (sexp form body))) + `(gv-get ,place (lambda ,vars ,@body))) + +;; Different ways to declare a generalized variable. +;;;###autoload +(defmacro gv-define-expander (name handler) + "Use HANDLER to handle NAME as a generalized var. +NAME is a symbol: the name of a function, macro, or special form. +HANDLER is a function which takes an argument DO followed by the same +arguments as NAME. DO is a function as defined in `gv-get'." + (declare (indent 1) (debug (sexp form))) + ;; Use eval-and-compile so the method can be used in the same file as it + ;; is defined. + ;; FIXME: Just like byte-compile-macro-environment, we should have something + ;; like byte-compile-symbolprop-environment so as to handle these things + ;; cleanly without affecting the running Emacs. + `(eval-and-compile (put ',name 'gv-expander ,handler))) + +;;;###autoload +(defun gv--defun-declaration (symbol name args handler &optional fix) + `(progn + ;; No need to autoload this part, since gv-get will auto-load the + ;; function's definition before checking the `gv-expander' property. + :autoload-end + ,(pcase (cons symbol handler) + (`(gv-expander . (lambda (,do) . ,body)) + `(gv-define-expander ,name (lambda (,do ,@args) ,@body))) + (`(gv-expander . ,(pred symbolp)) + `(gv-define-expander ,name #',handler)) + (`(gv-setter . (lambda (,store) . ,body)) + `(gv-define-setter ,name (,store ,@args) ,@body)) + (`(gv-setter . ,(pred symbolp)) + `(gv-define-simple-setter ,name ,handler ,fix)) + ;; (`(expand ,expander) `(gv-define-expand ,name ,expander)) + (_ (message "Unknown %s declaration %S" symbol handler) nil)))) + +;;;###autoload +(push `(gv-expander ,(apply-partially #'gv--defun-declaration 'gv-expander)) + defun-declarations-alist) +;;;###autoload +(push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter)) + defun-declarations-alist) + +;; (defmacro gv-define-expand (name expander) +;; "Use EXPANDER to handle NAME as a generalized var. +;; NAME is a symbol: the name of a function, macro, or special form. +;; EXPANDER is a function that will be called as a macro-expander to reduce +;; uses of NAME to some other generalized variable." +;; (declare (debug (sexp form))) +;; `(eval-and-compile +;; (if (not (boundp 'gv--macro-environment)) +;; (setq gv--macro-environment nil)) +;; (push (cons ',name ,expander) gv--macro-environment))) + +(defun gv--defsetter (name setter do args &optional vars) + "Helper function used by code generated by `gv-define-setter'. +NAME is the name of the getter function. +SETTER is a function that generates the code for the setter. +NAME accept ARGS as arguments and SETTER accepts (NEWVAL . ARGS). +VARS is used internally for recursive calls." + (if (null args) + (let ((vars (nreverse vars))) + (funcall do `(,name ,@vars) (lambda (v) (apply setter v vars)))) + ;; FIXME: Often it would be OK to skip this `let', but in general, + ;; `do' may have all kinds of side-effects. + (macroexp-let2 nil v (car args) + (gv--defsetter name setter do (cdr args) (cons v vars))))) + +;;;###autoload +(defmacro gv-define-setter (name arglist &rest body) + "Define a setter method for generalized variable NAME. +This macro is an easy-to-use substitute for `gv-define-expander' that works +well for simple place forms. +Assignments of VAL to (NAME ARGS...) are expanded by binding the argument +forms (VAL ARGS...) according to ARGLIST, then executing BODY, which must +return a Lisp form that does the assignment. +The first arg in ARGLIST (the one that receives VAL) receives an expression +which can do arbitrary things, whereas the other arguments are all guaranteed +to be pure and copyable. Example use: + (gv-define-setter aref (v a i) `(aset ,a ,i ,v))" + (declare (indent 2) (debug (&define name sexp body))) + `(gv-define-expander ,name + (lambda (do &rest args) + (gv--defsetter ',name (lambda ,arglist ,@body) do args)))) + +;;;###autoload +(defmacro gv-define-simple-setter (name setter &optional fix-return) + "Define a simple setter method for generalized variable NAME. +This macro is an easy-to-use substitute for `gv-define-expander' that works +well for simple place forms. Assignments of VAL to (NAME ARGS...) are +turned into calls of the form (SETTER ARGS... VAL). + +If FIX-RETURN is non-nil, then SETTER is not assumed to return VAL and +instead the assignment is turned into something equivalent to + \(let ((temp VAL)) + (SETTER ARGS... temp) + temp) +so as to preserve the semantics of `setf'." + (declare (debug (sexp (&or symbolp lambda-expr) &optional sexp))) + `(gv-define-setter ,name (val &rest args) + ,(if fix-return + `(macroexp-let2 nil v val + `(progn + (,',setter ,@(append args (list v))) + ,v)) + `(cons ',setter (append args (list val)))))) + +;;; Typical operations on generalized variables. + +;;;###autoload +(defmacro setf (&rest args) + "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 (cadr x) y) is equivalent to (setcar (cdr x) y). +The return value is the last VAL in the list. + +\(fn PLACE VAL PLACE VAL ...)" + (declare (debug (&rest [gv-place form]))) + (if (and args (null (cddr args))) + (let ((place (pop args)) + (val (car args))) + (gv-letplace (_getter setter) place + (funcall setter val))) + (let ((sets nil)) + (while args (push `(setf ,(pop args) ,(pop args)) sets)) + (cons 'progn (nreverse sets))))) + +;; (defmacro gv-pushnew! (val place) +;; "Like `gv-push!' but only adds VAL if it's not yet in PLACE. +;; Presence is checked with `member'. +;; The return value is unspecified." +;; (declare (debug (form gv-place))) +;; (macroexp-let2 macroexp-copyable-p v val +;; (gv-letplace (getter setter) place +;; `(if (member ,v ,getter) nil +;; ,(funcall setter `(cons ,v ,getter)))))) + +;; (defmacro gv-inc! (place &optional val) +;; "Increment PLACE by VAL (default to 1)." +;; (declare (debug (gv-place &optional form))) +;; (gv-letplace (getter setter) place +;; (funcall setter `(+ ,getter ,(or val 1))))) + +;; (defmacro gv-dec! (place &optional val) +;; "Decrement PLACE by VAL (default to 1)." +;; (declare (debug (gv-place &optional form))) +;; (gv-letplace (getter setter) place +;; (funcall setter `(- ,getter ,(or val 1))))) + +;; For Edebug, the idea is to let Edebug instrument gv-places just like it does +;; for normal expressions, and then give it a gv-expander to DTRT. +;; Maybe this should really be in edebug.el rather than here. + +;; Autoload this `put' since a user might use C-u C-M-x on an expression +;; containing a non-trivial `push' even before gv.el was loaded. +;;;###autoload +(put 'gv-place 'edebug-form-spec 'edebug-match-form) +;; CL did the equivalent of: +;;(gv-define-macroexpand edebug-after (lambda (before index place) place)) + +(put 'edebug-after 'gv-expander + (lambda (do before index place) + (gv-letplace (getter setter) place + (funcall do `(edebug-after ,before ,index ,getter) + setter)))) + +;;; The common generalized variables. + +(gv-define-simple-setter aref aset) +(gv-define-simple-setter car setcar) +(gv-define-simple-setter cdr setcdr) +;; FIXME: add compiler-macros for `cXXr' instead! +(gv-define-setter caar (val x) `(setcar (car ,x) ,val)) +(gv-define-setter cadr (val x) `(setcar (cdr ,x) ,val)) +(gv-define-setter cdar (val x) `(setcdr (car ,x) ,val)) +(gv-define-setter cddr (val x) `(setcdr (cdr ,x) ,val)) +(gv-define-setter elt (store seq n) + `(if (listp ,seq) (setcar (nthcdr ,n ,seq) ,store) + (aset ,seq ,n ,store))) +(gv-define-simple-setter get put) +(gv-define-setter gethash (val k h &optional _d) `(puthash ,k ,val ,h)) + +;; (gv-define-expand nth (lambda (idx list) `(car (nthcdr ,idx ,list)))) +(put 'nth 'gv-expander + (lambda (do idx list) + (macroexp-let2 nil c `(nthcdr ,idx ,list) + (funcall do `(car ,c) (lambda (v) `(setcar ,c ,v)))))) +(gv-define-simple-setter symbol-function fset) +(gv-define-simple-setter symbol-plist setplist) +(gv-define-simple-setter symbol-value set) + +(put 'nthcdr 'gv-expander + (lambda (do n place) + (macroexp-let2 nil idx n + (gv-letplace (getter setter) place + (funcall do `(nthcdr ,idx ,getter) + (lambda (v) `(if (<= ,idx 0) ,(funcall setter v) + (setcdr (nthcdr (1- ,idx) ,getter) ,v)))))))) + +;;; Elisp-specific generalized variables. + +(gv-define-simple-setter default-value set-default) +(gv-define-simple-setter frame-parameter set-frame-parameter 'fix) +(gv-define-simple-setter terminal-parameter set-terminal-parameter) +(gv-define-simple-setter keymap-parent set-keymap-parent) +(gv-define-simple-setter match-data set-match-data 'fix) +(gv-define-simple-setter overlay-get overlay-put) +(gv-define-setter overlay-start (store ov) + `(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store)) +(gv-define-setter overlay-end (store ov) + `(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store)) +(gv-define-simple-setter process-buffer set-process-buffer) +(gv-define-simple-setter process-filter set-process-filter) +(gv-define-simple-setter process-sentinel set-process-sentinel) +(gv-define-simple-setter process-get process-put) +(gv-define-simple-setter window-buffer set-window-buffer) +(gv-define-simple-setter window-display-table set-window-display-table 'fix) +(gv-define-simple-setter window-dedicated-p set-window-dedicated-p) +(gv-define-simple-setter window-hscroll set-window-hscroll) +(gv-define-simple-setter window-parameter set-window-parameter) +(gv-define-simple-setter window-point set-window-point) +(gv-define-simple-setter window-start set-window-start) + +;;; Some occasionally handy extensions. + +;; While several of the "places" below are not terribly useful for direct use, +;; they can show up as the output of the macro expansion of reasonable places, +;; such as struct-accessors. + +(put 'progn 'gv-expander + (lambda (do &rest exps) + (let ((start (butlast exps)) + (end (car (last exps)))) + (if (null start) (gv-get end do) + `(progn ,@start ,(gv-get end do)))))) + +(let ((let-expander + (lambda (letsym) + (lambda (do bindings &rest body) + `(,letsym ,bindings + ,@(macroexp-unprogn + (gv-get (macroexp-progn body) do))))))) + (put 'let 'gv-expander (funcall let-expander 'let)) + (put 'let* 'gv-expander (funcall let-expander 'let*))) + +(put 'if 'gv-expander + (lambda (do test then &rest else) + (if (or (not lexical-binding) ;The other code requires lexical-binding. + (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy)))) + ;; This duplicates the `do' code, which is a problem if that + ;; code is large, but otherwise results in more efficient code. + `(if ,test ,(gv-get then do) + ,@(macroexp-unprogn (gv-get (macroexp-progn else) do))) + (let ((v (make-symbol "v"))) + (macroexp-let2 nil + gv `(if ,test ,(gv-letplace (getter setter) then + `(cons (lambda () ,getter) + (lambda (,v) ,(funcall setter v)))) + ,(gv-letplace (getter setter) (macroexp-progn else) + `(cons (lambda () ,getter) + (lambda (,v) ,(funcall setter v))))) + (funcall do `(funcall (car ,gv)) + (lambda (v) `(funcall (cdr ,gv) ,v)))))))) + +(put 'cond 'gv-expander + (lambda (do &rest branches) + (if (or (not lexical-binding) ;The other code requires lexical-binding. + (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy)))) + ;; This duplicates the `do' code, which is a problem if that + ;; code is large, but otherwise results in more efficient code. + `(cond + ,@(mapcar (lambda (branch) + (if (cdr branch) + (cons (car branch) + (macroexp-unprogn + (gv-get (macroexp-progn (cdr branch)) do))) + (gv-get (car branch) do))) + branches)) + (let ((v (make-symbol "v"))) + (macroexp-let2 nil + gv `(cond + ,@(mapcar + (lambda (branch) + (if (cdr branch) + `(,(car branch) + ,@(macroexp-unprogn + (gv-letplace (getter setter) + (macroexp-progn (cdr branch)) + `(cons (lambda () ,getter) + (lambda (,v) ,(funcall setter v)))))) + (gv-letplace (getter setter) + (car branch) + `(cons (lambda () ,getter) + (lambda (,v) ,(funcall setter v)))))) + branches)) + (funcall do `(funcall (car ,gv)) + (lambda (v) `(funcall (cdr ,gv) ,v)))))))) + +;;; Even more debatable extensions. + +(put 'cons 'gv-expander + (lambda (do a d) + (gv-letplace (agetter asetter) a + (gv-letplace (dgetter dsetter) d + (funcall do + `(cons ,agetter ,dgetter) + (lambda (v) `(progn + ,(funcall asetter `(car ,v)) + ,(funcall dsetter `(cdr ,v))))))))) + +(put 'logand 'gv-expander + (lambda (do place &rest masks) + (gv-letplace (getter setter) place + (macroexp-let2 macroexp-copyable-p + mask (if (cdr masks) `(logand ,@masks) (car masks)) + (funcall + do `(logand ,getter ,mask) + (lambda (v) + (funcall setter + `(logior (logand ,v ,mask) + (logand ,getter (lognot ,mask)))))))))) + +;;; Vaguely related definitions that should be moved elsewhere. + +;; (defun alist-get (key alist) +;; "Get the value associated to KEY in ALIST." +;; (declare +;; (gv-expander +;; (lambda (do) +;; (macroexp-let2 macroexp-copyable-p k key +;; (gv-letplace (getter setter) alist +;; (macroexp-let2 nil p `(assoc ,k ,getter) +;; (funcall do `(cdr ,p) +;; (lambda (v) +;; `(if ,p (setcdr ,p ,v) +;; ,(funcall setter +;; `(cons (cons ,k ,v) ,getter))))))))))) +;; (cdr (assoc key alist))) + +(provide 'gv) +;;; gv.el ends here diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index 09ee1a68f68..f3b7de521cf 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -1,11 +1,11 @@ ;;; helper.el --- utility help package supporting help in electric modes -;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1985, 2001-2013 Free Software Foundation, Inc. ;; Author: K. Shane Hartman ;; Maintainer: FSF ;; Keywords: help +;; Package: emacs ;; This file is part of GNU Emacs. @@ -155,5 +155,4 @@ (provide 'helper) -;; arch-tag: a0984577-d3e9-4124-ae0d-c46fe740f6a9 ;;; helper.el ends here diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index c1989eeb6ad..024790d7b4b 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -1,7 +1,7 @@ ;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -;; Copyright (C) 1992, 1994, 1997, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1994, 1997, 2000-2013 Free Software Foundation, +;; Inc. ;; Author: Eric S. Raymond <esr@snark.thyrsus.com> ;; Maintainer: FSF @@ -298,6 +298,7 @@ The returned value is a list of strings, one per line." (defmacro lm-with-file (file &rest body) "Execute BODY in a buffer containing the contents of FILE. If FILE is nil, execute BODY in the current buffer." + (declare (indent 1) (debug t)) (let ((filesym (make-symbol "file"))) `(let ((,filesym ,file)) (if ,filesym @@ -311,9 +312,6 @@ If FILE is nil, execute BODY in the current buffer." (with-syntax-table emacs-lisp-mode-syntax-table ,@body)))))) -(put 'lm-with-file 'lisp-indent-function 1) -(put 'lm-with-file 'edebug-form-spec t) - ;; Fixme: Probably this should be amalgamated with copyright.el; also ;; we need a check for ranges in copyright years. @@ -458,7 +456,9 @@ each line." "Return list of keywords given in file FILE." (let ((keywords (lm-keywords file))) (if keywords - (split-string keywords "[, \t\n]+" t)))) + (if (string-match-p "," keywords) + (split-string keywords ",[ \t\n]*" t) + (split-string keywords "[ \t\n]+" t))))) (defvar finder-known-keywords) (defun lm-keywords-finder-p (&optional file) @@ -616,5 +616,4 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer." (provide 'lisp-mnt) -;; arch-tag: fa3c5ab4-a37b-4e46-b7cf-b6d78b90e69e ;;; lisp-mnt.el ends here diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index cbf2e0ccb71..fc1cfe7afd1 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1,10 +1,10 @@ ;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands -;; Copyright (C) 1985, 1986, 1999, 2000, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: lisp, languages +;; Package: emacs ;; This file is part of GNU Emacs. @@ -34,50 +34,56 @@ (defvar font-lock-string-face) (defvar lisp-mode-abbrev-table nil) +(define-abbrev-table 'lisp-mode-abbrev-table () + "Abbrev table for Lisp mode.") -(define-abbrev-table 'lisp-mode-abbrev-table ()) +(defvar emacs-lisp-mode-abbrev-table nil) +(define-abbrev-table 'emacs-lisp-mode-abbrev-table () + "Abbrev table for Emacs Lisp mode. +It has `lisp-mode-abbrev-table' as its parent." + :parents (list lisp-mode-abbrev-table)) (defvar emacs-lisp-mode-syntax-table - (let ((table (make-syntax-table))) - (let ((i 0)) - (while (< i ?0) - (modify-syntax-entry i "_ " table) - (setq i (1+ i))) - (setq i (1+ ?9)) - (while (< i ?A) - (modify-syntax-entry i "_ " table) - (setq i (1+ i))) - (setq i (1+ ?Z)) - (while (< i ?a) - (modify-syntax-entry i "_ " table) - (setq i (1+ i))) - (setq i (1+ ?z)) - (while (< i 128) - (modify-syntax-entry i "_ " table) - (setq i (1+ i))) - (modify-syntax-entry ?\s " " table) - ;; Non-break space acts as whitespace. - (modify-syntax-entry ?\x8a0 " " table) - (modify-syntax-entry ?\t " " table) - (modify-syntax-entry ?\f " " table) - (modify-syntax-entry ?\n "> " table) - ;; This is probably obsolete since nowadays such features use overlays. - ;; ;; Give CR the same syntax as newline, for selective-display. - ;; (modify-syntax-entry ?\^m "> " table) - (modify-syntax-entry ?\; "< " table) - (modify-syntax-entry ?` "' " table) - (modify-syntax-entry ?' "' " table) - (modify-syntax-entry ?, "' " table) - (modify-syntax-entry ?@ "' " table) - ;; Used to be singlequote; changed for flonums. - (modify-syntax-entry ?. "_ " table) - (modify-syntax-entry ?# "' " table) - (modify-syntax-entry ?\" "\" " table) - (modify-syntax-entry ?\\ "\\ " table) - (modify-syntax-entry ?\( "() " table) - (modify-syntax-entry ?\) ")( " table) - (modify-syntax-entry ?\[ "(] " table) - (modify-syntax-entry ?\] ")[ " table)) + (let ((table (make-syntax-table)) + (i 0)) + (while (< i ?0) + (modify-syntax-entry i "_ " table) + (setq i (1+ i))) + (setq i (1+ ?9)) + (while (< i ?A) + (modify-syntax-entry i "_ " table) + (setq i (1+ i))) + (setq i (1+ ?Z)) + (while (< i ?a) + (modify-syntax-entry i "_ " table) + (setq i (1+ i))) + (setq i (1+ ?z)) + (while (< i 128) + (modify-syntax-entry i "_ " table) + (setq i (1+ i))) + (modify-syntax-entry ?\s " " table) + ;; Non-break space acts as whitespace. + (modify-syntax-entry ?\x8a0 " " table) + (modify-syntax-entry ?\t " " table) + (modify-syntax-entry ?\f " " table) + (modify-syntax-entry ?\n "> " table) + ;; This is probably obsolete since nowadays such features use overlays. + ;; ;; Give CR the same syntax as newline, for selective-display. + ;; (modify-syntax-entry ?\^m "> " table) + (modify-syntax-entry ?\; "< " table) + (modify-syntax-entry ?` "' " table) + (modify-syntax-entry ?' "' " table) + (modify-syntax-entry ?, "' " table) + (modify-syntax-entry ?@ "' " table) + ;; Used to be singlequote; changed for flonums. + (modify-syntax-entry ?. "_ " table) + (modify-syntax-entry ?# "' " table) + (modify-syntax-entry ?\" "\" " table) + (modify-syntax-entry ?\\ "\\ " table) + (modify-syntax-entry ?\( "() " table) + (modify-syntax-entry ?\) ")( " table) + (modify-syntax-entry ?\[ "(] " table) + (modify-syntax-entry ?\] ")[ " table) table) "Syntax table used in `emacs-lisp-mode'.") @@ -85,7 +91,7 @@ (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) (modify-syntax-entry ?\[ "_ " table) (modify-syntax-entry ?\] "_ " table) - (modify-syntax-entry ?# "' 14b" table) + (modify-syntax-entry ?# "' 14" table) (modify-syntax-entry ?| "\" 23bn" table) table) "Syntax table used in `lisp-mode'.") @@ -111,10 +117,15 @@ (purecopy (concat "^\\s-*(" (eval-when-compile (regexp-opt - '("defvar" "defconst" "defconstant" "defcustom" + '("defconst" "defconstant" "defcustom" "defparameter" "define-symbol-macro") t)) "\\s-+\\(\\(\\sw\\|\\s_\\)+\\)")) 2) + ;; For `defvar', we ignore (defvar FOO) constructs. + (list (purecopy "Variables") + (purecopy (concat "^\\s-*(defvar\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" + "[[:space:]\n]+[^)]")) + 1) (list (purecopy "Types") (purecopy (concat "^\\s-*(" (eval-when-compile @@ -129,34 +140,12 @@ ;; This was originally in autoload.el and is still used there. (put 'autoload 'doc-string-elt 3) -(put 'defun 'doc-string-elt 3) -(put 'defun* 'doc-string-elt 3) +(put 'defmethod 'doc-string-elt 3) (put 'defvar 'doc-string-elt 3) -(put 'defcustom 'doc-string-elt 3) -(put 'deftheme 'doc-string-elt 2) -(put 'deftype 'doc-string-elt 3) (put 'defconst 'doc-string-elt 3) -(put 'defmacro 'doc-string-elt 3) -(put 'defmacro* 'doc-string-elt 3) -(put 'defsubst 'doc-string-elt 3) -(put 'defstruct 'doc-string-elt 2) -(put 'define-skeleton 'doc-string-elt 2) -(put 'define-derived-mode 'doc-string-elt 4) -(put 'define-compilation-mode 'doc-string-elt 3) -(put 'easy-mmode-define-minor-mode 'doc-string-elt 2) -(put 'define-minor-mode 'doc-string-elt 2) -(put 'easy-mmode-define-global-mode 'doc-string-elt 2) -(put 'define-global-minor-mode 'doc-string-elt 2) -(put 'define-globalized-minor-mode 'doc-string-elt 2) -(put 'define-generic-mode 'doc-string-elt 7) -(put 'define-ibuffer-filter 'doc-string-elt 2) -(put 'define-ibuffer-op 'doc-string-elt 3) -(put 'define-ibuffer-sorter 'doc-string-elt 2) -(put 'lambda 'doc-string-elt 2) (put 'defalias 'doc-string-elt 3) (put 'defvaralias 'doc-string-elt 3) (put 'define-category 'doc-string-elt 2) -(put 'define-overloadable-function 'doc-string-elt 3) (defvar lisp-doc-string-elt-property 'doc-string-elt "The symbol property that holds the docstring position info.") @@ -174,7 +163,8 @@ (goto-char listbeg) (and (looking-at "([ \t\n]*\\(\\(\\sw\\|\\s_\\)+\\)") (match-string 1))))) - (docelt (and firstsym (get (intern-soft firstsym) + (docelt (and firstsym + (function-get (intern-soft firstsym) lisp-doc-string-elt-property)))) (if (and docelt ;; It's a string in a form that can have a docstring. @@ -205,7 +195,6 @@ score-mode.el. KEYWORDS-CASE-INSENSITIVE non-nil means that for font-lock keywords will not be case sensitive." (when lisp-syntax (set-syntax-table lisp-mode-syntax-table)) - (setq local-abbrev-table lisp-mode-abbrev-table) (make-local-variable 'paragraph-ignore-fill-prefix) (setq paragraph-ignore-fill-prefix t) (make-local-variable 'fill-paragraph-function) @@ -221,8 +210,6 @@ font-lock keywords will not be case sensitive." ;;(set (make-local-variable 'adaptive-fill-mode) nil) (make-local-variable 'indent-line-function) (setq indent-line-function 'lisp-indent-line) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) (make-local-variable 'outline-regexp) (setq outline-regexp ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|(") (make-local-variable 'outline-level) @@ -283,110 +270,111 @@ font-lock keywords will not be case sensitive." (define-key map "\e\t" 'completion-at-point) (define-key map "\e\C-x" 'eval-defun) (define-key map "\e\C-q" 'indent-pp-sexp) - (define-key map [menu-bar emacs-lisp] (cons (purecopy "Emacs-Lisp") menu-map)) - (define-key menu-map [eldoc] - `(menu-item ,(purecopy "Auto-Display Documentation Strings") eldoc-mode + (bindings--define-key map [menu-bar emacs-lisp] + (cons "Emacs-Lisp" menu-map)) + (bindings--define-key menu-map [eldoc] + '(menu-item "Auto-Display Documentation Strings" eldoc-mode :button (:toggle . (bound-and-true-p eldoc-mode)) - :help ,(purecopy "Display the documentation string for the item under cursor"))) - (define-key menu-map [checkdoc] - `(menu-item ,(purecopy "Check Documentation Strings") checkdoc - :help ,(purecopy "Check documentation strings for style requirements"))) - (define-key menu-map [re-builder] - `(menu-item ,(purecopy "Construct Regexp") re-builder - :help ,(purecopy "Construct a regexp interactively"))) - (define-key menu-map [tracing] (cons (purecopy "Tracing") tracing-map)) - (define-key tracing-map [tr-a] - `(menu-item ,(purecopy "Untrace All") untrace-all - :help ,(purecopy "Untrace all currently traced functions"))) - (define-key tracing-map [tr-uf] - `(menu-item ,(purecopy "Untrace function...") untrace-function - :help ,(purecopy "Untrace function, and possibly activate all remaining advice"))) - (define-key tracing-map [tr-sep] menu-bar-separator) - (define-key tracing-map [tr-q] - `(menu-item ,(purecopy "Trace Function Quietly...") trace-function-background - :help ,(purecopy "Trace the function with trace output going quietly to a buffer"))) - (define-key tracing-map [tr-f] - `(menu-item ,(purecopy "Trace Function...") trace-function - :help ,(purecopy "Trace the function given as an argument"))) - (define-key menu-map [profiling] (cons (purecopy "Profiling") prof-map)) - (define-key prof-map [prof-restall] - `(menu-item ,(purecopy "Remove Instrumentation for All Functions") elp-restore-all - :help ,(purecopy "Restore the original definitions of all functions being profiled"))) - (define-key prof-map [prof-restfunc] - `(menu-item ,(purecopy "Remove Instrumentation for Function...") elp-restore-function - :help ,(purecopy "Restore an instrumented function to its original definition"))) - - (define-key prof-map [sep-rem] menu-bar-separator) - (define-key prof-map [prof-resall] - `(menu-item ,(purecopy "Reset Counters for All Functions") elp-reset-all - :help ,(purecopy "Reset the profiling information for all functions being profiled"))) - (define-key prof-map [prof-resfunc] - `(menu-item ,(purecopy "Reset Counters for Function...") elp-reset-function - :help ,(purecopy "Reset the profiling information for a function"))) - (define-key prof-map [prof-res] - `(menu-item ,(purecopy "Show Profiling Results") elp-results - :help ,(purecopy "Display current profiling results"))) - (define-key prof-map [prof-pack] - `(menu-item ,(purecopy "Instrument Package...") elp-instrument-package - :help ,(purecopy "Instrument for profiling all function that start with a prefix"))) - (define-key prof-map [prof-func] - `(menu-item ,(purecopy "Instrument Function...") elp-instrument-function - :help ,(purecopy "Instrument a function for profiling"))) - (define-key menu-map [lint] (cons (purecopy "Linting") lint-map)) - (define-key lint-map [lint-di] - `(menu-item ,(purecopy "Lint Directory...") elint-directory - :help ,(purecopy "Lint a directory"))) - (define-key lint-map [lint-f] - `(menu-item ,(purecopy "Lint File...") elint-file - :help ,(purecopy "Lint a file"))) - (define-key lint-map [lint-b] - `(menu-item ,(purecopy "Lint Buffer") elint-current-buffer - :help ,(purecopy "Lint the current buffer"))) - (define-key lint-map [lint-d] - `(menu-item ,(purecopy "Lint Defun") elint-defun - :help ,(purecopy "Lint the function at point"))) - (define-key menu-map [edebug-defun] - `(menu-item ,(purecopy "Instrument Function for Debugging") edebug-defun - :help ,(purecopy "Evaluate the top level form point is in, stepping through with Edebug") - :keys ,(purecopy "C-u C-M-x"))) - (define-key menu-map [separator-byte] menu-bar-separator) - (define-key menu-map [disas] - `(menu-item ,(purecopy "Disassemble Byte Compiled Object...") disassemble - :help ,(purecopy "Print disassembled code for OBJECT in a buffer"))) - (define-key menu-map [byte-recompile] - `(menu-item ,(purecopy "Byte-recompile Directory...") byte-recompile-directory - :help ,(purecopy "Recompile every `.el' file in DIRECTORY that needs recompilation"))) - (define-key menu-map [emacs-byte-compile-and-load] - `(menu-item ,(purecopy "Byte-compile and Load") emacs-lisp-byte-compile-and-load - :help ,(purecopy "Byte-compile the current file (if it has changed), then load compiled code"))) - (define-key menu-map [byte-compile] - `(menu-item ,(purecopy "Byte-compile this File") emacs-lisp-byte-compile - :help ,(purecopy "Byte compile the file containing the current buffer"))) - (define-key menu-map [separator-eval] menu-bar-separator) - (define-key menu-map [ielm] - `(menu-item ,(purecopy "Interactive Expression Evaluation") ielm - :help ,(purecopy "Interactively evaluate Emacs Lisp expressions"))) - (define-key menu-map [eval-buffer] - `(menu-item ,(purecopy "Evaluate Buffer") eval-buffer - :help ,(purecopy "Execute the current buffer as Lisp code"))) - (define-key menu-map [eval-region] - `(menu-item ,(purecopy "Evaluate Region") eval-region - :help ,(purecopy "Execute the region as Lisp code") + :help "Display the documentation string for the item under cursor")) + (bindings--define-key menu-map [checkdoc] + '(menu-item "Check Documentation Strings" checkdoc + :help "Check documentation strings for style requirements")) + (bindings--define-key menu-map [re-builder] + '(menu-item "Construct Regexp" re-builder + :help "Construct a regexp interactively")) + (bindings--define-key menu-map [tracing] (cons "Tracing" tracing-map)) + (bindings--define-key tracing-map [tr-a] + '(menu-item "Untrace All" untrace-all + :help "Untrace all currently traced functions")) + (bindings--define-key tracing-map [tr-uf] + '(menu-item "Untrace Function..." untrace-function + :help "Untrace function, and possibly activate all remaining advice")) + (bindings--define-key tracing-map [tr-sep] menu-bar-separator) + (bindings--define-key tracing-map [tr-q] + '(menu-item "Trace Function Quietly..." trace-function-background + :help "Trace the function with trace output going quietly to a buffer")) + (bindings--define-key tracing-map [tr-f] + '(menu-item "Trace Function..." trace-function + :help "Trace the function given as an argument")) + (bindings--define-key menu-map [profiling] (cons "Profiling" prof-map)) + (bindings--define-key prof-map [prof-restall] + '(menu-item "Remove Instrumentation for All Functions" elp-restore-all + :help "Restore the original definitions of all functions being profiled")) + (bindings--define-key prof-map [prof-restfunc] + '(menu-item "Remove Instrumentation for Function..." elp-restore-function + :help "Restore an instrumented function to its original definition")) + + (bindings--define-key prof-map [sep-rem] menu-bar-separator) + (bindings--define-key prof-map [prof-resall] + '(menu-item "Reset Counters for All Functions" elp-reset-all + :help "Reset the profiling information for all functions being profiled")) + (bindings--define-key prof-map [prof-resfunc] + '(menu-item "Reset Counters for Function..." elp-reset-function + :help "Reset the profiling information for a function")) + (bindings--define-key prof-map [prof-res] + '(menu-item "Show Profiling Results" elp-results + :help "Display current profiling results")) + (bindings--define-key prof-map [prof-pack] + '(menu-item "Instrument Package..." elp-instrument-package + :help "Instrument for profiling all function that start with a prefix")) + (bindings--define-key prof-map [prof-func] + '(menu-item "Instrument Function..." elp-instrument-function + :help "Instrument a function for profiling")) + (bindings--define-key menu-map [lint] (cons "Linting" lint-map)) + (bindings--define-key lint-map [lint-di] + '(menu-item "Lint Directory..." elint-directory + :help "Lint a directory")) + (bindings--define-key lint-map [lint-f] + '(menu-item "Lint File..." elint-file + :help "Lint a file")) + (bindings--define-key lint-map [lint-b] + '(menu-item "Lint Buffer" elint-current-buffer + :help "Lint the current buffer")) + (bindings--define-key lint-map [lint-d] + '(menu-item "Lint Defun" elint-defun + :help "Lint the function at point")) + (bindings--define-key menu-map [edebug-defun] + '(menu-item "Instrument Function for Debugging" edebug-defun + :help "Evaluate the top level form point is in, stepping through with Edebug" + :keys "C-u C-M-x")) + (bindings--define-key menu-map [separator-byte] menu-bar-separator) + (bindings--define-key menu-map [disas] + '(menu-item "Disassemble Byte Compiled Object..." disassemble + :help "Print disassembled code for OBJECT in a buffer")) + (bindings--define-key menu-map [byte-recompile] + '(menu-item "Byte-recompile Directory..." byte-recompile-directory + :help "Recompile every `.el' file in DIRECTORY that needs recompilation")) + (bindings--define-key menu-map [emacs-byte-compile-and-load] + '(menu-item "Byte-compile and Load" emacs-lisp-byte-compile-and-load + :help "Byte-compile the current file (if it has changed), then load compiled code")) + (bindings--define-key menu-map [byte-compile] + '(menu-item "Byte-compile This File" emacs-lisp-byte-compile + :help "Byte compile the file containing the current buffer")) + (bindings--define-key menu-map [separator-eval] menu-bar-separator) + (bindings--define-key menu-map [ielm] + '(menu-item "Interactive Expression Evaluation" ielm + :help "Interactively evaluate Emacs Lisp expressions")) + (bindings--define-key menu-map [eval-buffer] + '(menu-item "Evaluate Buffer" eval-buffer + :help "Execute the current buffer as Lisp code")) + (bindings--define-key menu-map [eval-region] + '(menu-item "Evaluate Region" eval-region + :help "Execute the region as Lisp code" :enable mark-active)) - (define-key menu-map [eval-sexp] - `(menu-item ,(purecopy "Evaluate Last S-expression") eval-last-sexp - :help ,(purecopy "Evaluate sexp before point; print value in minibuffer"))) - (define-key menu-map [separator-format] menu-bar-separator) - (define-key menu-map [comment-region] - `(menu-item ,(purecopy "Comment Out Region") comment-region - :help ,(purecopy "Comment or uncomment each line in the region") + (bindings--define-key menu-map [eval-sexp] + '(menu-item "Evaluate Last S-expression" eval-last-sexp + :help "Evaluate sexp before point; print value in minibuffer")) + (bindings--define-key menu-map [separator-format] menu-bar-separator) + (bindings--define-key menu-map [comment-region] + '(menu-item "Comment Out Region" comment-region + :help "Comment or uncomment each line in the region" :enable mark-active)) - (define-key menu-map [indent-region] - `(menu-item ,(purecopy "Indent Region") indent-region - :help ,(purecopy "Indent each nonblank line in the region") + (bindings--define-key menu-map [indent-region] + '(menu-item "Indent Region" indent-region + :help "Indent each nonblank line in the region" :enable mark-active)) - (define-key menu-map [indent-line] - `(menu-item ,(purecopy "Indent Line") lisp-indent-line)) + (bindings--define-key menu-map [indent-line] + '(menu-item "Indent Line" lisp-indent-line)) map) "Keymap for Emacs Lisp mode. All commands in `lisp-mode-shared-map' are inherited by this map.") @@ -408,10 +396,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") (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)))) + (byte-recompile-file buffer-file-name nil 0 t)) (defcustom emacs-lisp-mode-hook nil "Hook run when entering Emacs Lisp mode." @@ -431,7 +416,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") :type 'hook :group 'lisp) -(define-derived-mode emacs-lisp-mode nil "Emacs-Lisp" +(define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp" "Major mode for editing Lisp code to run in Emacs. Commands: Delete converts tabs to spaces as it moves back. @@ -446,27 +431,82 @@ if that value is non-nil." (add-hook 'completion-at-point-functions 'lisp-completion-at-point nil 'local)) +;;; Emacs Lisp Byte-Code mode + +(eval-and-compile + (defconst emacs-list-byte-code-comment-re + (concat "\\(#\\)@\\([0-9]+\\) " + ;; Make sure it's a docstring and not a lazy-loaded byte-code. + "\\(?:[^(]\\|([^\"]\\)"))) + +(defun emacs-lisp-byte-code-comment (end &optional _point) + "Try to syntactically mark the #@NNN ....^_ docstrings in byte-code files." + (let ((ppss (syntax-ppss))) + (when (and (nth 4 ppss) + (eq (char-after (nth 8 ppss)) ?#)) + (let* ((n (save-excursion + (goto-char (nth 8 ppss)) + (when (looking-at emacs-list-byte-code-comment-re) + (string-to-number (match-string 2))))) + ;; `maxdiff' tries to make sure the loop below terminates. + (maxdiff n)) + (when n + (let* ((bchar (match-end 2)) + (b (position-bytes bchar))) + (goto-char (+ b n)) + (while (let ((diff (- (position-bytes (point)) b n))) + (unless (zerop diff) + (when (> diff maxdiff) (setq diff maxdiff)) + (forward-char (- diff)) + (setq maxdiff (if (> diff 0) diff + (max (1- maxdiff) 1))) + t)))) + (if (<= (point) end) + (put-text-property (1- (point)) (point) + 'syntax-table + (string-to-syntax "> b")) + (goto-char end))))))) + +(defun emacs-lisp-byte-code-syntax-propertize (start end) + (emacs-lisp-byte-code-comment end (point)) + (funcall + (syntax-propertize-rules + (emacs-list-byte-code-comment-re + (1 (prog1 "< b" (emacs-lisp-byte-code-comment end (point)))))) + start end)) + +(add-to-list 'auto-mode-alist '("\\.elc\\'" . emacs-lisp-byte-code-mode)) +(define-derived-mode emacs-lisp-byte-code-mode emacs-lisp-mode + "Elisp-Byte-Code" + "Major mode for *.elc files." + ;; TODO: Add way to disassemble byte-code under point. + (setq-local open-paren-in-column-0-is-defun-start nil) + (setq-local syntax-propertize-function + #'emacs-lisp-byte-code-syntax-propertize)) + +;;; Generic Lisp mode. + (defvar lisp-mode-map (let ((map (make-sparse-keymap)) (menu-map (make-sparse-keymap "Lisp"))) (set-keymap-parent map lisp-mode-shared-map) (define-key map "\e\C-x" 'lisp-eval-defun) (define-key map "\C-c\C-z" 'run-lisp) - (define-key map [menu-bar lisp] (cons (purecopy "Lisp") menu-map)) - (define-key menu-map [run-lisp] - `(menu-item ,(purecopy "Run inferior Lisp") run-lisp - :help ,(purecopy "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'"))) - (define-key menu-map [ev-def] - `(menu-item ,(purecopy "Eval defun") lisp-eval-defun - :help ,(purecopy "Send the current defun to the Lisp process made by M-x run-lisp"))) - (define-key menu-map [ind-sexp] - `(menu-item ,(purecopy "Indent sexp") indent-sexp - :help ,(purecopy "Indent each line of the list starting just after point"))) + (bindings--define-key map [menu-bar lisp] (cons "Lisp" menu-map)) + (bindings--define-key menu-map [run-lisp] + '(menu-item "Run inferior Lisp" run-lisp + :help "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'")) + (bindings--define-key menu-map [ev-def] + '(menu-item "Eval defun" lisp-eval-defun + :help "Send the current defun to the Lisp process made by M-x run-lisp")) + (bindings--define-key menu-map [ind-sexp] + '(menu-item "Indent sexp" indent-sexp + :help "Indent each line of the list starting just after point")) map) "Keymap for ordinary Lisp mode. All commands in `lisp-mode-shared-map' are inherited by this map.") -(defun lisp-mode () +(define-derived-mode lisp-mode prog-mode "Lisp" "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. Commands: Delete converts tabs to spaces as it moves back. @@ -478,19 +518,12 @@ 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 nil t) + (set (make-local-variable 'find-tag-default-function) 'lisp-find-tag-default) (make-local-variable 'comment-start-skip) (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") - (setq imenu-case-fold-search t) - (set-syntax-table lisp-mode-syntax-table) - (run-mode-hooks 'lisp-mode-hook)) -(put 'lisp-mode 'find-tag-default-function 'lisp-find-tag-default) + (setq imenu-case-fold-search t)) (defun lisp-find-tag-default () (let ((default (find-tag-default))) @@ -516,28 +549,28 @@ if that value is non-nil." (define-key map "\e\C-q" 'indent-pp-sexp) (define-key map "\e\t" 'completion-at-point) (define-key map "\n" 'eval-print-last-sexp) - (define-key map [menu-bar lisp-interaction] (cons (purecopy "Lisp-Interaction") menu-map)) - (define-key menu-map [eval-defun] - `(menu-item ,(purecopy "Evaluate Defun") eval-defun - :help ,(purecopy "Evaluate the top-level form containing point, or after point"))) - (define-key menu-map [eval-print-last-sexp] - `(menu-item ,(purecopy "Evaluate and print") eval-print-last-sexp - :help ,(purecopy "Evaluate sexp before point; print value into current buffer"))) - (define-key menu-map [edebug-defun-lisp-interaction] - `(menu-item ,(purecopy "Instrument Function for Debugging") edebug-defun - :help ,(purecopy "Evaluate the top level form point is in, stepping through with Edebug") - :keys ,(purecopy "C-u C-M-x"))) - (define-key menu-map [indent-pp-sexp] - `(menu-item ,(purecopy "Indent or Pretty-Print") indent-pp-sexp - :help ,(purecopy "Indent each line of the list starting just after point, or prettyprint it"))) - (define-key menu-map [complete-symbol] - `(menu-item ,(purecopy "Complete Lisp Symbol") completion-at-point - :help ,(purecopy "Perform completion on Lisp symbol preceding point"))) + (bindings--define-key map [menu-bar lisp-interaction] + (cons "Lisp-Interaction" menu-map)) + (bindings--define-key menu-map [eval-defun] + '(menu-item "Evaluate Defun" eval-defun + :help "Evaluate the top-level form containing point, or after point")) + (bindings--define-key menu-map [eval-print-last-sexp] + '(menu-item "Evaluate and Print" eval-print-last-sexp + :help "Evaluate sexp before point; print value into current buffer")) + (bindings--define-key menu-map [edebug-defun-lisp-interaction] + '(menu-item "Instrument Function for Debugging" edebug-defun + :help "Evaluate the top level form point is in, stepping through with Edebug" + :keys "C-u C-M-x")) + (bindings--define-key menu-map [indent-pp-sexp] + '(menu-item "Indent or Pretty-Print" indent-pp-sexp + :help "Indent each line of the list starting just after point, or prettyprint it")) + (bindings--define-key menu-map [complete-symbol] + '(menu-item "Complete Lisp Symbol" completion-at-point + :help "Perform completion on Lisp symbol preceding point")) map) "Keymap for Lisp Interaction mode. All commands in `lisp-mode-shared-map' are inherited by this map.") -(defvar lisp-interaction-mode-abbrev-table lisp-mode-abbrev-table) (define-derived-mode lisp-interaction-mode emacs-lisp-mode "Lisp Interaction" "Major mode for typing and evaluating Lisp forms. Like Lisp mode except that \\[eval-print-last-sexp] evals the Lisp expression @@ -552,7 +585,8 @@ 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.") +if that value is non-nil." + :abbrev-table nil) (defun eval-print-last-sexp () "Evaluate sexp before point; print value into current buffer. @@ -711,7 +745,9 @@ If CHAR is not a character, return nil." "Evaluate sexp before point; print value in minibuffer. With argument, print output into current buffer." (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) - (eval-last-sexp-print-value (eval (preceding-sexp))))) + ;; Setup the lexical environment if lexical-binding is enabled. + (eval-last-sexp-print-value + (eval (eval-sexp-add-defvars (preceding-sexp)) lexical-binding)))) (defun eval-last-sexp-print-value (value) @@ -739,6 +775,25 @@ With argument, print output into current buffer." (defvar eval-last-sexp-fake-value (make-symbol "t")) +(defun eval-sexp-add-defvars (exp &optional pos) + "Prepend EXP with all the `defvar's that precede it in the buffer. +POS specifies the starting position where EXP was found and defaults to point." + (if (not lexical-binding) + exp + (save-excursion + (unless pos (setq pos (point))) + (let ((vars ())) + (goto-char (point-min)) + (while (re-search-forward + "(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)" + pos t) + (let ((var (intern (match-string 1)))) + (and (not (special-variable-p var)) + (save-excursion + (zerop (car (syntax-ppss (match-beginning 0))))) + (push var vars)))) + `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp))))) + (defun eval-last-sexp (eval-last-sexp-arg-internal) "Evaluate sexp before point; print value in minibuffer. Interactively, with prefix argument, print output into current buffer. @@ -763,7 +818,7 @@ this command arranges for all errors to enter the debugger." Reset the `defvar' and `defcustom' variables to the initial value. Reinitialize the face according to the `defface' specification." ;; The code in edebug-defun should be consistent with this, but not - ;; the same, since this gets a macroexpended form. + ;; the same, since this gets a macroexpanded form. (cond ((not (listp form)) form) ((and (eq (car form) 'defvar) @@ -775,30 +830,38 @@ Reinitialize the face according to the `defface' specification." ;; `defcustom' is now macroexpanded to ;; `custom-declare-variable' with a quoted value arg. ((and (eq (car form) 'custom-declare-variable) - (default-boundp (eval (nth 1 form)))) + (default-boundp (eval (nth 1 form) lexical-binding))) ;; Force variable to be bound. - (set-default (eval (nth 1 form)) (eval (nth 1 (nth 2 form)))) + (set-default (eval (nth 1 form) lexical-binding) + ;; The second arg is an expression that evaluates to + ;; an expression. The second evaluation is the one + ;; normally performed not be normal execution but by + ;; custom-initialize-set (for example), which does not + ;; use lexical-binding. + (eval (eval (nth 2 form) lexical-binding))) form) ;; `defface' is macroexpanded to `custom-declare-face'. ((eq (car form) 'custom-declare-face) ;; Reset the face. - (setq face-new-frame-defaults - (assq-delete-all (eval (nth 1 form)) face-new-frame-defaults)) - (put (eval (nth 1 form)) 'face-defface-spec nil) - ;; Setting `customized-face' to the new spec after calling - ;; the form, but preserving the old saved spec in `saved-face', - ;; imitates the situation when the new face spec is set - ;; temporarily for the current session in the customize - ;; buffer, thus allowing `face-user-default-spec' to use the - ;; new customized spec instead of the saved spec. - ;; Resetting `saved-face' temporarily to nil is needed to let - ;; `defface' change the spec, regardless of a saved spec. - (prog1 `(prog1 ,form - (put ,(nth 1 form) 'saved-face - ',(get (eval (nth 1 form)) 'saved-face)) - (put ,(nth 1 form) 'customized-face - ,(nth 2 form))) - (put (eval (nth 1 form)) 'saved-face nil))) + (let ((face-symbol (eval (nth 1 form) lexical-binding))) + (setq face-new-frame-defaults + (assq-delete-all face-symbol face-new-frame-defaults)) + (put face-symbol 'face-defface-spec nil) + (put face-symbol 'face-documentation (nth 3 form)) + ;; Setting `customized-face' to the new spec after calling + ;; the form, but preserving the old saved spec in `saved-face', + ;; imitates the situation when the new face spec is set + ;; temporarily for the current session in the customize + ;; buffer, thus allowing `face-user-default-spec' to use the + ;; new customized spec instead of the saved spec. + ;; Resetting `saved-face' temporarily to nil is needed to let + ;; `defface' change the spec, regardless of a saved spec. + (prog1 `(prog1 ,form + (put ,(nth 1 form) 'saved-face + ',(get face-symbol 'saved-face)) + (put ,(nth 1 form) 'customized-face + ,(nth 2 form))) + (put face-symbol 'saved-face nil)))) ((eq (car form) 'progn) (cons 'progn (mapcar 'eval-defun-1 (cdr form)))) (t form))) @@ -814,7 +877,6 @@ if it already has a value.\) With argument, insert value in current buffer after the defun. Return the result of evaluation." - (interactive "P") ;; FIXME: the print-length/level bindings should only be applied while ;; printing, not while evaluating. (let ((debug-on-error eval-expression-debug-on-error) @@ -837,7 +899,7 @@ Return the result of evaluation." (setq form (read (current-buffer))) (setq end (point))) ;; Alter the form if necessary. - (setq form (eval-defun-1 (macroexpand form))) + (setq form (eval-sexp-add-defvars (eval-defun-1 (macroexpand form)))) (list beg end standard-output `(lambda (ignore) ;; Skipping to the end of the specified region @@ -919,6 +981,7 @@ rigidly along with this one." (if (or (null indent) (looking-at "\\s<\\s<\\s<")) ;; Don't alter indentation of a ;;; comment line ;; or a line that starts in a string. + ;; FIXME: inconsistency: comment-indent moves ;;; to column 0. (goto-char (- (point-max) pos)) (if (and (looking-at "\\s<") (not (looking-at "\\s<\\s<"))) ;; Single-semicolon comment lines should be indented @@ -933,18 +996,7 @@ rigidly along with this one." ;; 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))))) + (goto-char (- (point-max) pos)))))) (defvar calculate-lisp-indent-last-sexp) @@ -1078,7 +1130,7 @@ is the buffer position of the start of the containing expression." (goto-char calculate-lisp-indent-last-sexp) (or (and (looking-at ":") (setq indent (current-column))) - (and (< (save-excursion (beginning-of-line) (point)) + (and (< (line-beginning-position) (prog2 (backward-sexp) (point))) (looking-at ":") (setq indent (current-column)))) @@ -1093,25 +1145,31 @@ is the buffer position of the start of the containing expression." (defun lisp-indent-function (indent-point state) "This function is the normal value of the variable `lisp-indent-function'. -It is used when indenting a line within a function call, to see if the -called function says anything special about how to indent the line. +The function `calculate-lisp-indent' calls this to determine +if the arguments of a Lisp function call should be indented specially. -INDENT-POINT is the position where the user typed TAB, or equivalent. +INDENT-POINT is the position at which the line being indented begins. Point is located at the point to indent under (for default indentation); STATE is the `parse-partial-sexp' state for that position. -If the current line is in a call to a Lisp function -which has a non-nil property `lisp-indent-function', -that specifies how to do the indentation. The property value can be -* `defun', meaning indent `defun'-style; +If the current line is in a call to a Lisp function that has a non-nil +property `lisp-indent-function' (or the deprecated `lisp-indent-hook'), +it specifies how to indent. The property value can be: + +* `defun', meaning indent `defun'-style + \(this is also the case if there is no property and the function + has a name that begins with \"def\", and three or more arguments); + * an integer N, meaning indent the first N arguments specially - like ordinary function arguments and then indent any further + (like ordinary function arguments), and then indent any further arguments like a body; -* a function to call just as this function was called. - If that function returns nil, that means it doesn't specify - the indentation. -This function also returns nil meaning don't specify the indentation." +* a function to call that returns the indentation (or nil). + `lisp-indent-function' calls this function with the same two arguments + that it itself received. + +This function returns either the indentation to use, or nil if the +Lisp function does not specify a special indentation." (let ((normal-indent (current-column))) (goto-char (1+ (elt state 1))) (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) @@ -1134,7 +1192,8 @@ This function also returns nil meaning don't specify the indentation." (let ((function (buffer-substring (point) (progn (forward-sexp 1) (point)))) method) - (setq method (or (get (intern-soft function) 'lisp-indent-function) + (setq method (or (function-get (intern-soft function) + 'lisp-indent-function) (get (intern-soft function) 'lisp-indent-hook))) (cond ((or (eq method 'defun) (and (null method) @@ -1211,38 +1270,21 @@ This function also returns nil meaning don't specify the indentation." ;; 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 'with-temp-message 'lisp-indent-function 1) -(put 'with-syntax-table 'lisp-indent-function 1) (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 'read-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) -(put 'dolist 'lisp-indent-function 1) -(put 'dotimes 'lisp-indent-function 1) -(put 'when 'lisp-indent-function 1) -(put 'unless 'lisp-indent-function 1) (defun indent-sexp (&optional endpos) "Indent each line of the list starting just after point. @@ -1454,5 +1496,4 @@ means don't indent that line." (provide 'lisp-mode) -;; arch-tag: 414c7f93-c245-4b77-8ed5-ed05ef7ff1bf ;;; lisp-mode.el ends here diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index ed1ae918607..22fb6ad1809 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -1,10 +1,11 @@ ;;; lisp.el --- Lisp editing commands for Emacs -;; Copyright (C) 1985, 1986, 1994, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1994, 2000-2013 Free Software Foundation, +;; Inc. ;; Maintainer: FSF ;; Keywords: lisp, languages +;; Package: emacs ;; This file is part of GNU Emacs. @@ -140,9 +141,19 @@ A negative argument means move backward but still to a less deep spot. This command assumes point is not in a string or comment." (interactive "^p") (or arg (setq arg 1)) - (let ((inc (if (> arg 0) 1 -1))) + (let ((inc (if (> arg 0) 1 -1)) + pos) (while (/= arg 0) - (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))) + (if (null forward-sexp-function) + (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))) + (condition-case err + (while (progn (setq pos (point)) + (forward-sexp inc) + (/= (point) pos))) + (scan-error (goto-char (nth (if (> arg 0) 3 2) err)))) + (if (= (point) pos) + (signal 'scan-error + (list "Unbalanced parentheses" (point) (point))))) (setq arg (- arg inc))))) (defun kill-sexp (&optional arg) @@ -247,9 +258,8 @@ is called as a function to find the defun's beginning." (if (> arg 0) (dotimes (i arg) (funcall beginning-of-defun-function)) - ;; Better not call end-of-defun-function directly, in case - ;; it's not defined. - (end-of-defun (- arg)))))) + (dotimes (i (- arg)) + (funcall end-of-defun-function)))))) ((or defun-prompt-regexp open-paren-in-column-0-is-defun-start) (and (< arg 0) (not (eobp)) (forward-char 1)) @@ -438,7 +448,21 @@ Optional ARG is ignored." ;; Try first in this order for the sake of languages with nested ;; functions where several can end at the same place as with ;; the offside rule, e.g. Python. - (beginning-of-defun) + + ;; Finding the start of the function is a bit problematic since + ;; `beginning-of-defun' when we are on the first character of + ;; the function might go to the previous function. + ;; + ;; Therefore we first move one character forward and then call + ;; `beginning-of-defun'. However now we must check that we did + ;; not move into the next function. + (let ((here (point))) + (unless (eolp) + (forward-char)) + (beginning-of-defun) + (when (< (point) here) + (goto-char here) + (beginning-of-defun))) (setq beg (point)) (end-of-defun) (setq end (point)) @@ -624,46 +648,58 @@ considered." (interactive) (let* ((data (lisp-completion-at-point predicate)) (plist (nthcdr 3 data))) - (let ((completion-annotate-function - (plist-get plist :annotation-function))) - (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data) - (plist-get plist :predicate))))) + (if (null data) + (minibuffer-message "Nothing to complete") + (let ((completion-extra-properties plist)) + (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data) + (plist-get plist :predicate)))))) (defun lisp-completion-at-point (&optional predicate) "Function used for `completion-at-point-functions' in `emacs-lisp-mode'." ;; FIXME: the `end' could be after point? (with-syntax-table emacs-lisp-mode-syntax-table - (let* ((end (point)) - (beg (save-excursion - (backward-sexp 1) - (while (= (char-syntax (following-char)) ?\') - (forward-char 1)) - (point))) - (predicate - (or predicate - (save-excursion - (goto-char beg) - (if (not (eq (char-before) ?\()) - (lambda (sym) ;why not just nil ? -sm - (or (boundp sym) (fboundp sym) - (symbol-plist sym))) - ;; Looks like a funcall position. Let's double check. - (if (condition-case nil - (progn (up-list -2) (forward-char 1) - (eq (char-after) ?\()) - (error nil)) - ;; If the first element of the parent list is an open - ;; paren we are probably not in a funcall position. - ;; Maybe a `let' varlist or something. - nil - ;; Else, we assume that a function name is expected. - 'fboundp)))))) - (list beg end obarray - :predicate predicate - :annotation-function - (unless (eq predicate 'fboundp) - (lambda (str) (if (fboundp (intern-soft str)) " <f>"))))))) - -;; arch-tag: aa7fa8a4-2e6f-4e9b-9cd9-fef06340e67e + (let* ((pos (point)) + (beg (condition-case nil + (save-excursion + (backward-sexp 1) + (skip-syntax-forward "'") + (point)) + (scan-error pos))) + (predicate + (or predicate + (save-excursion + (goto-char beg) + (if (not (eq (char-before) ?\()) + (lambda (sym) ;why not just nil ? -sm + (or (boundp sym) (fboundp sym) + (symbol-plist sym))) + ;; Looks like a funcall position. Let's double check. + (if (condition-case nil + (progn (up-list -2) (forward-char 1) + (eq (char-after) ?\()) + (error nil)) + ;; If the first element of the parent list is an open + ;; paren we are probably not in a funcall position. + ;; Maybe a `let' varlist or something. + nil + ;; Else, we assume that a function name is expected. + 'fboundp))))) + (end + (unless (or (eq beg (point-max)) + (member (char-syntax (char-after beg)) '(?\" ?\( ?\)))) + (condition-case nil + (save-excursion + (goto-char beg) + (forward-sexp 1) + (when (>= (point) pos) + (point))) + (scan-error pos))))) + (when end + (list beg end obarray + :predicate predicate + :annotation-function + (unless (eq predicate 'fboundp) + (lambda (str) (if (fboundp (intern-soft str)) " <f>")))))))) + ;;; lisp.el ends here diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index de06bf4f761..3bf08ee8a97 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -1,6 +1,6 @@ -;;; macroexp.el --- Additional macro-expansion support +;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t; coding: utf-8 -*- ;; -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2004-2013 Free Software Foundation, Inc. ;; ;; Author: Miles Bader <miles@gnu.org> ;; Keywords: lisp, compiler, macros @@ -33,7 +33,7 @@ ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) -(defun maybe-cons (car cdr original-cons) +(defun macroexp--cons (car cdr original-cons) "Return (CAR . CDR), using ORIGINAL-CONS if possible." (if (and (eq car (car original-cons)) (eq cdr (cdr original-cons))) original-cons @@ -41,9 +41,9 @@ ;; We use this special macro to iteratively process forms and share list ;; structure of the result with the input. Doing so recursively using -;; `maybe-cons' results in excessively deep recursion for very long +;; `macroexp--cons' results in excessively deep recursion for very long ;; input forms. -(defmacro macroexp-accumulate (var+list &rest body) +(defmacro macroexp--accumulate (var+list &rest body) "Return a list of the results of evaluating BODY for each element of LIST. Evaluate BODY with VAR bound to each `car' from LIST, in turn. Return a list of the values of the final form in BODY. @@ -52,6 +52,7 @@ possible (for instance, when BODY just returns VAR unchanged, the result will be eq to LIST). \(fn (VAR LIST) BODY...)" + (declare (indent 1)) (let ((var (car var+list)) (list (cadr var+list)) (shared (make-symbol "shared")) @@ -62,7 +63,7 @@ result will be eq to LIST). (,unshared nil) (,tail ,shared) ,var ,new-el) - (while ,tail + (while (consp ,tail) (setq ,var (car ,tail) ,new-el (progn ,@body)) (unless (eq ,var ,new-el) @@ -72,29 +73,70 @@ result will be eq to LIST). (push ,new-el ,unshared)) (setq ,tail (cdr ,tail))) (nconc (nreverse ,unshared) ,shared)))) -(put 'macroexp-accumulate 'lisp-indent-function 1) -(defun macroexpand-all-forms (forms &optional skip) +(defun macroexp--all-forms (forms &optional skip) "Return FORMS with macros expanded. FORMS is a list of forms. If SKIP is non-nil, then don't expand that many elements at the start of FORMS." - (macroexp-accumulate (form forms) + (macroexp--accumulate (form forms) (if (or (null skip) (zerop skip)) - (macroexpand-all-1 form) + (macroexp--expand-all form) (setq skip (1- skip)) form))) -(defun macroexpand-all-clauses (clauses &optional skip) +(defun macroexp--all-clauses (clauses &optional skip) "Return CLAUSES with macros expanded. CLAUSES is a list of lists of forms; any clause that's not a list is ignored. If SKIP is non-nil, then don't expand that many elements at the start of each clause." - (macroexp-accumulate (clause clauses) + (macroexp--accumulate (clause clauses) (if (listp clause) - (macroexpand-all-forms clause skip) + (macroexp--all-forms clause skip) clause))) -(defun macroexpand-all-1 (form) +(defun macroexp--compiler-macro (handler form) + (condition-case err + (apply handler form (cdr form)) + (error (message "Compiler-macro error for %S: %S" (car form) err) + form))) + +(defun macroexp--funcall-if-compiled (_form) + "Pseudo function used internally by macroexp to delay warnings. +The purpose is to delay warnings to bytecomp.el, so they can use things +like `byte-compile-log-warning' to get better file-and-line-number data +and also to avoid outputting the warning during normal execution." + nil) +(put 'macroexp--funcall-if-compiled 'byte-compile + (lambda (form) + (funcall (eval (cadr form))) + (byte-compile-constant nil))) + +(defun macroexp--warn-and-return (msg form) + (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) + (cond + ((null msg) form) + ;; FIXME: ¡¡Major Ugly Hack!! To determine whether the output of this + ;; macro-expansion will be processed by the byte-compiler, we check + ;; circumstantial evidence. + ((member '(declare-function . byte-compile-macroexpand-declare-function) + macroexpand-all-environment) + `(progn + (macroexp--funcall-if-compiled ',when-compiled) + ,form)) + (t + (message "%s" msg) + form)))) + +(defun macroexp--obsolete-warning (fun obsolescence-data type) + (let ((instead (car obsolescence-data)) + (asof (nth 2 obsolescence-data))) + (format "`%s' is an obsolete %s%s%s" fun type + (if asof (concat " (as of " asof ")") "") + (cond ((stringp instead) (concat "; " instead)) + (instead (format "; use `%s' instead." instead)) + (t "."))))) + +(defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. Assumes the caller has bound `macroexpand-all-environment'." @@ -103,84 +145,107 @@ Assumes the caller has bound `macroexpand-all-environment'." ;; generates exceedingly deep expansions from relatively shallow input ;; forms. We just process it `in reverse' -- first we expand all the ;; arguments, _then_ we expand the top-level definition. - (macroexpand (macroexpand-all-forms form 1) + (macroexpand (macroexp--all-forms form 1) macroexpand-all-environment) ;; Normal form; get its expansion, and then expand arguments. - (setq form (macroexpand form macroexpand-all-environment)) - (if (consp form) - (let ((fun (car form))) - (cond - ((eq fun 'cond) - (maybe-cons fun (macroexpand-all-clauses (cdr form)) form)) - ((eq fun 'condition-case) - (maybe-cons - fun - (maybe-cons (cadr form) - (maybe-cons (macroexpand-all-1 (nth 2 form)) - (macroexpand-all-clauses (nthcdr 3 form) 1) - (cddr form)) - (cdr form)) - form)) - ((eq fun 'defmacro) - (push (cons (cadr form) (cons 'lambda (cddr form))) - macroexpand-all-environment) - (macroexpand-all-forms form 3)) - ((eq fun 'defun) - (macroexpand-all-forms form 3)) - ((memq fun '(defvar defconst)) - (macroexpand-all-forms form 2)) - ((eq fun 'function) - (if (and (consp (cadr form)) (eq (car (cadr form)) 'lambda)) - (maybe-cons fun - (maybe-cons (macroexpand-all-forms (cadr form) 2) - nil - (cadr form)) - form) - form)) - ((memq fun '(let let*)) - (maybe-cons fun - (maybe-cons (macroexpand-all-clauses (cadr form) 1) - (macroexpand-all-forms (cddr form)) - (cdr form)) - form)) - ((eq fun 'quote) - form) - ((and (consp fun) (eq (car fun) 'lambda)) - ;; embedded lambda - (maybe-cons (macroexpand-all-forms fun 2) - (macroexpand-all-forms (cdr form)) - form)) - ;; The following few cases are for normal function calls that - ;; are known to funcall one of their arguments. The byte - ;; compiler has traditionally handled these functions specially - ;; by treating a lambda expression quoted by `quote' as if it - ;; were quoted by `function'. We make the same transformation - ;; here, so that any code that cares about the difference will - ;; see the same transformation. - ;; First arg is a function: - ((and (memq fun '(apply mapcar mapatoms mapconcat mapc)) - (consp (cadr form)) - (eq (car (cadr form)) 'quote)) - ;; We don't use `maybe-cons' since there's clearly a change. - (cons fun - (cons (macroexpand-all-1 (cons 'function (cdr (cadr form)))) - (macroexpand-all-forms (cddr form))))) - ;; Second arg is a function: - ((and (eq fun 'sort) - (consp (nth 2 form)) - (eq (car (nth 2 form)) 'quote)) - ;; We don't use `maybe-cons' since there's clearly a change. - (cons fun - (cons (macroexpand-all-1 (cadr form)) - (cons (macroexpand-all-1 - (cons 'function (cdr (nth 2 form)))) - (macroexpand-all-forms (nthcdr 3 form)))))) - (t - ;; For everything else, we just expand each argument (for - ;; setq/setq-default this works alright because the variable names - ;; are symbols). - (macroexpand-all-forms form 1)))) - form))) + (let ((new-form + (macroexpand form macroexpand-all-environment))) + (setq form + (if (and (not (eq form new-form)) ;It was a macro call. + (car-safe form) + (symbolp (car form)) + (get (car form) 'byte-obsolete-info) + (or (not (fboundp 'byte-compile-warning-enabled-p)) + (byte-compile-warning-enabled-p 'obsolete))) + (let* ((fun (car form)) + (obsolete (get fun 'byte-obsolete-info))) + (macroexp--warn-and-return + (macroexp--obsolete-warning + fun obsolete + (if (symbolp (symbol-function fun)) + "alias" "macro")) + new-form)) + new-form))) + (pcase form + (`(cond . ,clauses) + (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) + (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare)) + (macroexp--cons + 'condition-case + (macroexp--cons err + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form)) + (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2)) + (`(function ,(and f `(lambda . ,_))) + (macroexp--cons 'function + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form)) + (`(,(or `function `quote) . ,_) form) + (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare)) + (macroexp--cons fun + (macroexp--cons (macroexp--all-clauses bindings 1) + (macroexp--all-forms body) + (cdr form)) + form)) + (`(,(and fun `(lambda . ,_)) . ,args) + ;; Embedded lambda in function position. + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form)) + ;; The following few cases are for normal function calls that + ;; are known to funcall one of their arguments. The byte + ;; compiler has traditionally handled these functions specially + ;; by treating a lambda expression quoted by `quote' as if it + ;; were quoted by `function'. We make the same transformation + ;; here, so that any code that cares about the difference will + ;; see the same transformation. + ;; First arg is a function: + (`(,(and fun (or `funcall `apply `mapcar `mapatoms `mapconcat `mapc)) + ',(and f `(lambda . ,_)) . ,args) + (macroexp--warn-and-return + (format "%s quoted with ' rather than with #'" + (list 'lambda (nth 1 f) '...)) + (macroexp--expand-all `(,fun ,f . ,args)))) + ;; Second arg is a function: + (`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) + (macroexp--warn-and-return + (format "%s quoted with ' rather than with #'" + (list 'lambda (nth 1 f) '...)) + (macroexp--expand-all `(,fun ,arg1 ,f . ,args)))) + (`(,func . ,_) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. + (let ((handler (function-get func 'compiler-macro))) + (if (null handler) + ;; No compiler macro. We just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexp--all-forms form 1) + ;; If the handler is not loaded yet, try (auto)loading the + ;; function itself, which may in turn load the handler. + (unless (functionp handler) + (ignore-errors + (autoload-do-load (indirect-function func) func))) + (let ((newform (macroexp--compiler-macro handler form))) + (if (eq form newform) + ;; The compiler macro did not find anything to do. + (if (equal form (setq newform (macroexp--all-forms form 1))) + form + ;; Maybe after processing the args, some new opportunities + ;; appeared, so let's try the compiler macro again. + (setq form (macroexp--compiler-macro handler newform)) + (if (eq newform form) + newform + (macroexp--expand-all newform))) + (macroexp--expand-all newform)))))) + + (t form)))) ;;;###autoload (defun macroexpand-all (form &optional environment) @@ -189,9 +254,191 @@ If no macros are expanded, FORM is returned unchanged. The second optional arg ENVIRONMENT specifies an environment of macro definitions to shadow the loaded ones for use in file byte-compilation." (let ((macroexpand-all-environment environment)) - (macroexpand-all-1 form))) + (macroexp--expand-all form))) + +;;; Handy functions to use in macros. + +(defun macroexp-progn (exps) + "Return an expression equivalent to `(progn ,@EXPS)." + (if (cdr exps) `(progn ,@exps) (car exps))) + +(defun macroexp-unprogn (exp) + "Turn EXP into a list of expressions to execute in sequence." + (if (eq (car-safe exp) 'progn) (cdr exp) (list exp))) + +(defun macroexp-let* (bindings exp) + "Return an expression equivalent to `(let* ,bindings ,exp)." + (cond + ((null bindings) exp) + ((eq 'let* (car-safe exp)) `(let* (,@bindings ,@(cadr exp)) ,@(cddr exp))) + (t `(let* ,bindings ,exp)))) + +(defun macroexp-if (test then else) + "Return an expression equivalent to `(if ,test ,then ,else)." + (cond + ((eq (car-safe else) 'if) + (if (equal test (nth 1 else)) + ;; Doing a test a second time: get rid of the redundancy. + `(if ,test ,then ,@(nthcdr 3 else)) + `(cond (,test ,then) + (,(nth 1 else) ,(nth 2 else)) + (t ,@(nthcdr 3 else))))) + ((eq (car-safe else) 'cond) + `(cond (,test ,then) + ;; Doing a test a second time: get rid of the redundancy, as above. + ,@(remove (assoc test else) (cdr else)))) + ;; Invert the test if that lets us reduce the depth of the tree. + ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then)) + (t `(if ,test ,then ,else)))) + +(defmacro macroexp-let2 (test var exp &rest exps) + "Bind VAR to a copyable expression that returns the value of EXP. +This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated +symbol which EXPS can find in VAR. +TEST should be the name of a predicate on EXP checking whether the `let' can +be skipped; if nil, as is usual, `macroexp-const-p' is used." + (declare (indent 3) (debug (sexp sexp form body))) + (let ((bodysym (make-symbol "body")) + (expsym (make-symbol "exp"))) + `(let* ((,expsym ,exp) + (,var (if (funcall #',(or test #'macroexp-const-p) ,expsym) + ,expsym (make-symbol ,(symbol-name var)))) + (,bodysym ,(macroexp-progn exps))) + (if (eq ,var ,expsym) ,bodysym + (macroexp-let* (list (list ,var ,expsym)) + ,bodysym))))) + +(defun macroexp--maxsize (exp size) + (cond ((< size 0) size) + ((symbolp exp) (1- size)) + ((stringp exp) (- size (/ (length exp) 16))) + ((vectorp exp) + (dotimes (i (length exp)) + (setq size (macroexp--maxsize (aref exp i) size))) + (1- size)) + ((consp exp) + ;; We could try to be more clever with quote&function, + ;; but it is difficult to do so correctly, and it's not obvious that + ;; it would be worth the effort. + (dolist (e exp) + (setq size (macroexp--maxsize e size))) + (1- size)) + (t -1))) + +(defun macroexp-small-p (exp) + "Return non-nil if EXP can be considered small." + (> (macroexp--maxsize exp 10) 0)) + +(defsubst macroexp--const-symbol-p (symbol &optional any-value) + "Non-nil if SYMBOL is constant. +If ANY-VALUE is nil, only return non-nil if the value of the symbol is the +symbol itself." + (or (memq symbol '(nil t)) + (keywordp symbol) + (if any-value + (or (memq symbol byte-compile-const-variables) + ;; FIXME: We should provide a less intrusive way to find out + ;; if a variable is "constant". + (and (boundp symbol) + (condition-case nil + (progn (set symbol (symbol-value symbol)) nil) + (setting-constant t))))))) + +(defun macroexp-const-p (exp) + "Return non-nil if EXP will always evaluate to the same value." + (cond ((consp exp) (or (eq (car exp) 'quote) + (and (eq (car exp) 'function) + (symbolp (cadr exp))))) + ;; It would sometimes make sense to pass `any-value', but it's not + ;; always safe since a "constant" variable may not actually always have + ;; the same value. + ((symbolp exp) (macroexp--const-symbol-p exp)) + (t t))) + +(defun macroexp-copyable-p (exp) + "Return non-nil if EXP can be copied without extra cost." + (or (symbolp exp) (macroexp-const-p exp))) + +;;; Load-time macro-expansion. + +;; Because macro-expansion used to be more lazy, eager macro-expansion +;; tends to bump into previously harmless/unnoticeable cyclic-dependencies. +;; So, we have to delay macro-expansion like we used to when we detect +;; such a cycle, and we also want to help coders resolve those cycles (since +;; they can be non-obvious) by providing a usefully trimmed backtrace +;; (hopefully) highlighting the problem. + +(defun macroexp--backtrace () + "Return the Elisp backtrace, more recent frames first." + (let ((bt ()) + (i 0)) + (while + (let ((frame (backtrace-frame i))) + (when frame + (push frame bt) + (setq i (1+ i))))) + (nreverse bt))) + +(defun macroexp--trim-backtrace-frame (frame) + (pcase frame + (`(,_ macroexpand (,head . ,_) . ,_) `(macroexpand (,head …))) + (`(,_ internal-macroexpand-for-load (,head ,second . ,_) . ,_) + (if (or (symbolp second) + (and (eq 'quote (car-safe second)) + (symbolp (cadr second)))) + `(macroexpand-all (,head ,second …)) + '(macroexpand-all …))) + (`(,_ load-with-code-conversion ,name . ,_) + `(load ,(file-name-nondirectory name))))) + +(defvar macroexp--pending-eager-loads nil + "Stack of files currently undergoing eager macro-expansion.") + +(defun internal-macroexpand-for-load (form) + ;; Called from the eager-macroexpansion in readevalloop. + (cond + ;; Don't repeat the same warning for every top-level element. + ((eq 'skip (car macroexp--pending-eager-loads)) form) + ;; If we detect a cycle, skip macro-expansion for now, and output a warning + ;; with a trimmed backtrace. + ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) + (let* ((bt (delq nil + (mapcar #'macroexp--trim-backtrace-frame + (macroexp--backtrace)))) + (elem `(load ,(file-name-nondirectory load-file-name))) + (tail (member elem (cdr (member elem bt))))) + (if tail (setcdr tail (list '…))) + (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) + (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => ")) + (push 'skip macroexp--pending-eager-loads) + form)) + (t + (condition-case err + (let ((macroexp--pending-eager-loads + (cons load-file-name macroexp--pending-eager-loads))) + (macroexpand-all form)) + (error + ;; Hopefully this shouldn't happen thanks to the cycle detection, + ;; but in case it does happen, let's catch the error and give the + ;; code a chance to macro-expand later. + (message "Eager macro-expansion failure: %S" err) + form))))) + +;; ¡¡¡ Big Ugly Hack !!! +;; src/bootstrap-emacs is mostly used to compile .el files, so it needs +;; macroexp, bytecomp, cconv, and byte-opt to be fast. Generally this is done +;; by compiling those files first, but this only makes a difference if those +;; files are not preloaded. But macroexp.el is preloaded so we reload it if +;; the current version is interpreted and there's a compiled version available. +(eval-when-compile + (add-hook 'emacs-startup-hook + (lambda () + (and (not (byte-code-function-p + (symbol-function 'macroexpand-all))) + (locate-library "macroexp.elc") + (load "macroexp.elc"))))) (provide 'macroexp) -;; arch-tag: af9b8c24-c196-43bc-91e1-a3570790fa5a ;;; macroexp.el ends here diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 95febfec3f4..13202a9ce4d 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -1,11 +1,11 @@ ;;; map-ynp.el --- general-purpose boolean question-asker -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1991-1995, 2000-2013 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Maintainer: FSF ;; Keywords: lisp, extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -123,16 +123,6 @@ Returns the number of actions taken." map (let ((map (make-sparse-keymap))) (set-keymap-parent map query-replace-map) - (define-key map [?\C-\M-v] 'scroll-other-window) - (define-key map [M-next] 'scroll-other-window) - (define-key map [?\C-\M-\S-v] 'scroll-other-window-down) - (define-key map [M-prior] 'scroll-other-window-down) - ;; The above are rather inconvenient, so maybe we should - ;; provide the non-other keys for the other-scroll as well. - ;; (define-key map [?\C-v] 'scroll-other-window) - ;; (define-key map [next] 'scroll-other-window) - ;; (define-key map [?\M-v] 'scroll-other-window-down) - ;; (define-key map [prior] 'scroll-other-window-down) (dolist (elt action-alist) (define-key map (vector (car elt)) (vector (nth 1 elt)))) map))) @@ -275,5 +265,4 @@ the current %s and exit." ;; Return the number of actions that were taken. actions)) -;; arch-tag: 1d0a3201-a151-4c10-b231-4da47c9e6dc3 ;;; map-ynp.el ends here diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el new file mode 100644 index 00000000000..a3ce1672a63 --- /dev/null +++ b/lisp/emacs-lisp/package-x.el @@ -0,0 +1,307 @@ +;;; package-x.el --- Package extras + +;; Copyright (C) 2007-2013 Free Software Foundation, Inc. + +;; Author: Tom Tromey <tromey@redhat.com> +;; Created: 10 Mar 2007 +;; Version: 0.9 +;; Keywords: tools +;; Package: package + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file currently contains parts of the package system that many +;; won't need, such as package uploading. + +;; To upload to an archive, first set `package-archive-upload-base' to +;; some desired directory. For testing purposes, you can specify any +;; directory you want, but if you want the archive to be accessible to +;; others via http, this is typically a directory in the /var/www tree +;; (possibly one on a remote machine, accessed via Tramp). + +;; Then call M-x package-upload-file, which prompts for a file to +;; upload. Alternatively, M-x package-upload-buffer uploads the +;; current buffer, if it's visiting a package file. + +;; Once a package is uploaded, users can access it via the Package +;; Menu, by adding the archive to `package-archives'. + +;;; Code: + +(require 'package) +(defvar gnus-article-buffer) + +(defcustom package-archive-upload-base "/path/to/archive" + "The base location of the archive to which packages are uploaded. +This should be an absolute directory name. If the archive is on +another machine, you may specify a remote name in the usual way, +e.g. \"/ssh:foo@example.com:/var/www/packages/\". +See Info node `(emacs)Remote Files'. + +Unlike `package-archives', you can't specify a HTTP URL." + :type 'directory + :group 'package + :version "24.1") + +(defvar package-update-news-on-upload nil + "Whether uploading a package should also update NEWS and RSS feeds.") + +(defun package--encode (string) + "Encode a string by replacing some characters with XML entities." + ;; We need a special case for translating "&" to "&". + (let ((index)) + (while (setq index (string-match "[&]" string index)) + (setq string (replace-match "&" t nil string)) + (setq index (1+ index)))) + (while (string-match "[<]" string) + (setq string (replace-match "<" t nil string))) + (while (string-match "[>]" string) + (setq string (replace-match ">" t nil string))) + (while (string-match "[']" string) + (setq string (replace-match "'" t nil string))) + (while (string-match "[\"]" string) + (setq string (replace-match """ t nil string))) + string) + +(defun package--make-rss-entry (title text archive-url) + (let ((date-string (format-time-string "%a, %d %B %Y %T %z"))) + (concat "<item>\n" + "<title>" (package--encode title) "</title>\n" + ;; FIXME: should have a link in the web page. + "<link>" archive-url "news.html</link>\n" + "<description>" (package--encode text) "</description>\n" + "<pubDate>" date-string "</pubDate>\n" + "</item>\n"))) + +(defun package--make-html-entry (title text) + (concat "<li> " (format-time-string "%B %e") " - " + title " - " (package--encode text) + " </li>\n")) + +(defun package--update-file (file tag text) + "Update the package archive file named FILE. +FILE should be relative to `package-archive-upload-base'. +TAG is a string that can be found within the file; TEXT is +inserted after its first occurrence in the file." + (setq file (expand-file-name file package-archive-upload-base)) + (save-excursion + (let ((old-buffer (find-buffer-visiting file))) + (with-current-buffer (let ((find-file-visit-truename t)) + (or old-buffer (find-file-noselect file))) + (goto-char (point-min)) + (search-forward tag) + (forward-line) + (insert text) + (let ((file-precious-flag t)) + (save-buffer)) + (unless old-buffer + (kill-buffer (current-buffer))))))) + +(defun package--archive-contents-from-url (archive-url) + "Parse archive-contents file at ARCHIVE-URL. +Return the file contents, as a string, or nil if unsuccessful." + (ignore-errors + (when archive-url + (let* ((buffer (url-retrieve-synchronously + (concat archive-url "archive-contents")))) + (set-buffer buffer) + (package-handle-response) + (re-search-forward "^$" nil 'move) + (forward-char) + (delete-region (point-min) (point)) + (prog1 (package-read-from-string + (buffer-substring-no-properties (point-min) (point-max))) + (kill-buffer buffer)))))) + +(defun package--archive-contents-from-file () + "Parse the archive-contents at `package-archive-upload-base'" + (let ((file (expand-file-name "archive-contents" + package-archive-upload-base))) + (if (not (file-exists-p file)) + ;; No existing archive-contents means a new archive. + (list package-archive-version) + (let ((dont-kill (find-buffer-visiting file))) + (with-current-buffer (let ((find-file-visit-truename t)) + (find-file-noselect file)) + (prog1 + (package-read-from-string + (buffer-substring-no-properties (point-min) (point-max))) + (unless dont-kill + (kill-buffer (current-buffer))))))))) + +(defun package-maint-add-news-item (title description archive-url) + "Add a news item to the webpages associated with the package archive. +TITLE is the title of the news item. +DESCRIPTION is the text of the news item." + (interactive "sTitle: \nsText: ") + (package--update-file "elpa.rss" + "<description>" + (package--make-rss-entry title description archive-url)) + (package--update-file "news.html" + "New entries go here" + (package--make-html-entry title description))) + +(defun package--update-news (package version description archive-url) + "Update the ELPA web pages when a package is uploaded." + (package-maint-add-news-item (concat package " version " version) + description + archive-url)) + +(defun package-upload-buffer-internal (pkg-info extension &optional archive-url) + "Upload a package whose contents are in the current buffer. +PKG-INFO is the package info, see `package-buffer-info'. +EXTENSION is the file extension, a string. It can be either +\"el\" or \"tar\". + +The upload destination is given by `package-archive-upload-base'. +If its value is invalid, prompt for a directory. + +Optional arg ARCHIVE-URL is the URL of the destination archive. +If it is non-nil, compute the new \"archive-contents\" file +starting from the existing \"archive-contents\" at that URL. In +addition, if `package-update-news-on-upload' is non-nil, call +`package--update-news' to add a news item at that URL. + +If ARCHIVE-URL is nil, compute the new \"archive-contents\" file +from the \"archive-contents\" at `package-archive-upload-base', +if it exists." + (let ((package-archive-upload-base package-archive-upload-base)) + ;; Check if `package-archive-upload-base' is valid. + (when (or (not (stringp package-archive-upload-base)) + (equal package-archive-upload-base + (car-safe + (get 'package-archive-upload-base 'standard-value)))) + (setq package-archive-upload-base + (read-directory-name + "Base directory for package archive: "))) + (unless (file-directory-p package-archive-upload-base) + (if (y-or-n-p (format "%s does not exist; create it? " + package-archive-upload-base)) + (make-directory package-archive-upload-base t) + (error "Aborted"))) + (save-excursion + (save-restriction + (let* ((file-type (cond + ((equal extension "el") 'single) + ((equal extension "tar") 'tar) + (t (error "Unknown extension `%s'" extension)))) + (file-name (aref pkg-info 0)) + (pkg-name (intern file-name)) + (requires (aref pkg-info 1)) + (desc (if (string= (aref pkg-info 2) "") + (read-string "Description of package: ") + (aref pkg-info 2))) + (pkg-version (aref pkg-info 3)) + (commentary (aref pkg-info 4)) + (split-version (version-to-list pkg-version)) + (pkg-buffer (current-buffer))) + + ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or + ;; from `package-archive-upload-base' otherwise. + (let ((contents (or (package--archive-contents-from-url archive-url) + (package--archive-contents-from-file))) + (new-desc (vector split-version requires desc file-type))) + (if (> (car contents) package-archive-version) + (error "Unrecognized archive version %d" (car contents))) + (let ((elt (assq pkg-name (cdr contents)))) + (if elt + (if (version-list-<= split-version + (package-desc-vers (cdr elt))) + (error "New package has smaller version: %s" pkg-version) + (setcdr elt new-desc)) + (setq contents (cons (car contents) + (cons (cons pkg-name new-desc) + (cdr contents)))))) + + ;; Now CONTENTS is the updated archive contents. Upload + ;; this and the package itself. For now we assume ELPA is + ;; writable via file primitives. + (let ((print-level nil) + (print-length nil)) + (write-region (concat (pp-to-string contents) "\n") + nil + (expand-file-name "archive-contents" + package-archive-upload-base))) + + ;; If there is a commentary section, write it. + (when commentary + (write-region commentary nil + (expand-file-name + (concat (symbol-name pkg-name) "-readme.txt") + package-archive-upload-base))) + + (set-buffer pkg-buffer) + (write-region (point-min) (point-max) + (expand-file-name + (concat file-name "-" pkg-version "." extension) + package-archive-upload-base) + nil nil nil 'excl) + + ;; Write a news entry. + (and package-update-news-on-upload + archive-url + (package--update-news (concat file-name "." extension) + pkg-version desc archive-url)) + + ;; special-case "package": write a second copy so that the + ;; installer can easily find the latest version. + (if (string= file-name "package") + (write-region (point-min) (point-max) + (expand-file-name + (concat file-name "." extension) + package-archive-upload-base) + nil nil nil 'ask)))))))) + +(defun package-upload-buffer () + "Upload the current buffer as a single-file Emacs Lisp package. +If `package-archive-upload-base' does not specify a valid upload +destination, prompt for one." + (interactive) + (save-excursion + (save-restriction + ;; Find the package in this buffer. + (let ((pkg-info (package-buffer-info))) + (package-upload-buffer-internal pkg-info "el"))))) + +(defun package-upload-file (file) + "Upload the Emacs Lisp package FILE to the package archive. +Interactively, prompt for FILE. The package is considered a +single-file package if FILE ends in \".el\", and a multi-file +package if FILE ends in \".tar\". +If `package-archive-upload-base' does not specify a valid upload +destination, prompt for one." + (interactive "fPackage file name: ") + (with-temp-buffer + (insert-file-contents-literally file) + (let ((info (cond + ((string-match "\\.tar$" file) (package-tar-file-info file)) + ((string-match "\\.el$" file) (package-buffer-info)) + (t (error "Unrecognized extension `%s'" + (file-name-extension file)))))) + (package-upload-buffer-internal info (file-name-extension file))))) + +(defun package-gnus-summary-upload () + "Upload a package contained in the current *Article* buffer. +This should be invoked from the gnus *Summary* buffer." + (interactive) + (with-current-buffer gnus-article-buffer + (package-upload-buffer))) + +(provide 'package-x) + +;;; package-x.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el new file mode 100644 index 00000000000..6059f03f999 --- /dev/null +++ b/lisp/emacs-lisp/package.el @@ -0,0 +1,1751 @@ +;;; package.el --- Simple package system for Emacs + +;; Copyright (C) 2007-2013 Free Software Foundation, Inc. + +;; Author: Tom Tromey <tromey@redhat.com> +;; Created: 10 Mar 2007 +;; Version: 1.0 +;; Keywords: 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Change Log: + +;; 2 Apr 2007 - now using ChangeLog file +;; 15 Mar 2007 - updated documentation +;; 14 Mar 2007 - Changed how obsolete packages are handled +;; 13 Mar 2007 - Wrote package-install-from-buffer +;; 12 Mar 2007 - Wrote package-menu mode + +;;; Commentary: + +;; The idea behind package.el is to be able to download packages and +;; install them. Packages are versioned and have versioned +;; dependencies. Furthermore, this supports built-in packages which +;; may or may not be newer than user-specified packages. This makes +;; it possible to upgrade Emacs and automatically disable packages +;; which have moved from external to core. (Note though that we don't +;; currently register any of these, so this feature does not actually +;; work.) + +;; A package is described by its name and version. The distribution +;; format is either a tar file or a single .el file. + +;; A tar file should be named "NAME-VERSION.tar". The tar file must +;; unpack into a directory named after the package and version: +;; "NAME-VERSION". It must contain a file named "PACKAGE-pkg.el" +;; which consists of a call to define-package. It may also contain a +;; "dir" file and the info files it references. + +;; A .el file is named "NAME-VERSION.el" in the remote archive, but is +;; installed as simply "NAME.el" in a directory named "NAME-VERSION". + +;; The downloader downloads all dependent packages. By default, +;; packages come from the official GNU sources, but others may be +;; added by customizing the `package-archives' alist. Packages get +;; byte-compiled at install time. + +;; At activation time we will set up the load-path and the info path, +;; and we will load the package's autoloads. If a package's +;; dependencies are not available, we will not activate that package. + +;; Conceptually a package has multiple state transitions: +;; +;; * Download. Fetching the package from ELPA. +;; * Install. Untar the package, or write the .el file, into +;; ~/.emacs.d/elpa/ directory. +;; * Byte compile. Currently this phase is done during install, +;; but we may change this. +;; * Activate. Evaluate the autoloads for the package to make it +;; available to the user. +;; * Load. Actually load the package and run some code from it. + +;; Other external functions you may want to use: +;; +;; M-x list-packages +;; Enters a mode similar to buffer-menu which lets you manage +;; packages. You can choose packages for install (mark with "i", +;; then "x" to execute) or deletion (not implemented yet), and you +;; can see what packages are available. This will automatically +;; fetch the latest list of packages from ELPA. +;; +;; M-x package-install-from-buffer +;; Install a package consisting of a single .el file that appears +;; in the current buffer. This only works for packages which +;; define a Version header properly; package.el also supports the +;; extension headers Package-Version (in case Version is an RCS id +;; or similar), and Package-Requires (if the package requires other +;; packages). +;; +;; M-x package-install-file +;; Install a package from the indicated file. The package can be +;; either a tar file or a .el file. A tar file must contain an +;; appropriately-named "-pkg.el" file; a .el file must be properly +;; formatted as with package-install-from-buffer. + +;;; Thanks: +;;; (sorted by sort-lines): + +;; Jim Blandy <jimb@red-bean.com> +;; Karl Fogel <kfogel@red-bean.com> +;; Kevin Ryde <user42@zip.com.au> +;; Lawrence Mitchell +;; Michael Olson <mwolson@member.fsf.org> +;; Sebastian Tennant <sebyte@smolny.plus.com> +;; Stefan Monnier <monnier@iro.umontreal.ca> +;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Phil Hagelberg <phil@hagelb.org> + +;;; ToDo: + +;; - a trust mechanism, since compiling a package can run arbitrary code. +;; For example, download package signatures and check that they match. +;; - putting info dirs at the start of the info path means +;; users see a weird ordering of categories. OTOH we want to +;; override later entries. maybe emacs needs to enforce +;; the standard layout? +;; - put bytecode in a separate directory tree +;; - perhaps give users a way to recompile their bytecode +;; or do it automatically when emacs changes +;; - give users a way to know whether a package is installed ok +;; - give users a way to view a package's documentation when it +;; only appears in the .el +;; - use/extend checkdoc so people can tell if their package will work +;; - "installed" instead of a blank in the status column +;; - tramp needs its files to be compiled in a certain order. +;; how to handle this? fix tramp? +;; - on emacs 21 we don't kill the -autoloads.el buffer. what about 22? +;; - maybe we need separate .elc directories for various emacs versions +;; and also emacs-vs-xemacs. That way conditional compilation can +;; work. But would this break anything? +;; - should store the package's keywords in archive-contents, then +;; let the users filter the package-menu by keyword. See +;; finder-by-keyword. (We could also let people view the +;; Commentary, but it isn't clear how useful this is.) +;; - William Xu suggests being able to open a package file without +;; installing it +;; - Interface with desktop.el so that restarting after an install +;; works properly +;; - Implement M-x package-upgrade, to upgrade any/all existing packages +;; - Use hierarchical layout. PKG/etc PKG/lisp PKG/info +;; ... except maybe lisp? +;; - It may be nice to have a macro that expands to the package's +;; private data dir, aka ".../etc". Or, maybe data-directory +;; needs to be a list (though this would be less nice) +;; a few packages want this, eg sokoban +;; - package menu needs: +;; ability to know which packages are built-in & thus not deletable +;; it can sometimes print odd results, like 0.3 available but 0.4 active +;; why is that? +;; - Allow multiple versions on the server...? +;; [ why bother? ] +;; - Don't install a package which will invalidate dependencies overall +;; - Allow something like (or (>= emacs 21.0) (>= xemacs 21.5)) +;; [ currently thinking, why bother.. KISS ] +;; - Allow optional package dependencies +;; then if we require 'bbdb', bbdb-specific lisp in lisp/bbdb +;; and just don't compile to add to load path ...? +;; - Have a list of archive URLs? [ maybe there's no point ] +;; - David Kastrup pointed out on the xemacs list that for GPL it +;; is friendlier to ship the source tree. We could "support" that +;; by just having a "src" subdir in the package. This isn't ideal +;; but it probably is not worth trying to support random source +;; tree layouts, build schemes, etc. +;; - Our treatment of the info path is somewhat bogus +;; - perhaps have an "unstable" tree in ELPA as well as a stable one + +;;; Code: + +(require 'tabulated-list) + +(defgroup package nil + "Manager for Emacs Lisp packages." + :group 'applications + :version "24.1") + +;;;###autoload +(defcustom package-enable-at-startup t + "Whether to activate installed packages when Emacs starts. +If non-nil, packages are activated after reading the init file +and before `after-init-hook'. Activation is not done if +`user-init-file' is nil (e.g. Emacs was started with \"-q\"). + +Even if the value is nil, you can type \\[package-initialize] to +activate the package system at any time." + :type 'boolean + :group 'package + :version "24.1") + +(defcustom package-load-list '(all) + "List of packages for `package-initialize' to load. +Each element in this list should be a list (NAME VERSION), or the +symbol `all'. The symbol `all' says to load the latest installed +versions of all packages not specified by other elements. + +For an element (NAME VERSION), NAME is a package name (a symbol). +VERSION should be t, a string, or nil. +If VERSION is t, all versions are loaded, though obsolete ones + will be put in `package-obsolete-alist' and not activated. +If VERSION is a string, only that version is ever loaded. + Any other version, even if newer, is silently ignored. + Hence, the package is \"held\" at that version. +If VERSION is nil, the package is not loaded (it is \"disabled\")." + :type '(repeat symbol) + :risky t + :group 'package + :version "24.1") + +(defvar Info-directory-list) +(declare-function info-initialize "info" ()) +(declare-function url-http-parse-response "url-http" ()) +(declare-function lm-header "lisp-mnt" (header)) +(declare-function lm-commentary "lisp-mnt" (&optional file)) +(defvar url-http-end-of-headers) + +(defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) + "An alist of archives from which to fetch. +The default value points to the GNU Emacs package repository. + +Each element has the form (ID . LOCATION). + ID is an archive name, as a string. + LOCATION specifies the base location for the archive. + If it starts with \"http:\", it is treated as a HTTP URL; + otherwise it should be an absolute directory name. + (Other types of URL are currently not supported.) + +Only add locations that you trust, since fetching and installing +a package can run arbitrary code." + :type '(alist :key-type (string :tag "Archive name") + :value-type (string :tag "URL or directory name")) + :risky t + :group 'package + :version "24.1") + +(defconst package-archive-version 1 + "Version number of the package archive understood by this file. +Lower version numbers than this will probably be understood as well.") + +(defconst package-el-version "1.0" + "Version of package.el.") + +;; We don't prime the cache since it tends to get out of date. +(defvar package-archive-contents nil + "Cache of the contents of the Emacs Lisp Package Archive. +This is an alist mapping package names (symbols) to package +descriptor vectors. These are like the vectors for `package-alist' +but have extra entries: one which is 'tar for tar packages and +'single for single-file packages, and one which is the name of +the archive from which it came.") +(put 'package-archive-contents 'risky-local-variable t) + +(defcustom package-user-dir (locate-user-emacs-file "elpa") + "Directory containing the user's Emacs Lisp packages. +The directory name should be absolute. +Apart from this directory, Emacs also looks for system-wide +packages in `package-directory-list'." + :type 'directory + :risky t + :group 'package + :version "24.1") + +(defcustom package-directory-list + ;; Defaults are subdirs named "elpa" in the site-lisp dirs. + (let (result) + (dolist (f load-path) + (and (stringp f) + (equal (file-name-nondirectory f) "site-lisp") + (push (expand-file-name "elpa" f) result))) + (nreverse result)) + "List of additional directories containing Emacs Lisp packages. +Each directory name should be absolute. + +These directories contain packages intended for system-wide; in +contrast, `package-user-dir' contains packages for personal use." + :type '(repeat directory) + :risky t + :group 'package + :version "24.1") + +;; The value is precomputed in finder-inf.el, but don't load that +;; until it's needed (i.e. when `package-initialize' is called). +(defvar package--builtins nil + "Alist of built-in packages. +The actual value is initialized by loading the library +`finder-inf'; this is not done until it is needed, e.g. by the +function `package-built-in-p'. + +Each element has the form (PKG . DESC), where PKG is a package +name (a symbol) and DESC is a vector that describes the package. +The vector DESC has the form [VERSION-LIST REQS DOCSTRING]. + VERSION-LIST is a version list. + REQS is a list of packages required by the package, each + requirement having the form (NAME VL), where NAME is a string + and VL is a version list. + DOCSTRING is a brief description of the package.") +(put 'package--builtins 'risky-local-variable t) + +(defvar package-alist nil + "Alist of all packages available for activation. +Each element has the form (PKG . DESC), where PKG is a package +name (a symbol) and DESC is a vector that describes the package. + +The vector DESC has the form [VERSION-LIST REQS DOCSTRING]. + VERSION-LIST is a version list. + REQS is a list of packages required by the package, each + requirement having the form (NAME VL) where NAME is a string + and VL is a version list. + DOCSTRING is a brief description of the package. + +This variable is set automatically by `package-load-descriptor', +called via `package-initialize'. To change which packages are +loaded and/or activated, customize `package-load-list'.") +(put 'package-alist 'risky-local-variable t) + +(defvar package-activated-list nil + "List of the names of currently activated packages.") +(put 'package-activated-list 'risky-local-variable t) + +(defvar package-obsolete-alist nil + "Representation of obsolete packages. +Like `package-alist', but maps package name to a second alist. +The inner alist is keyed by version.") +(put 'package-obsolete-alist 'risky-local-variable t) + +(defun package-version-join (vlist) + "Return the version string corresponding to the list VLIST. +This is, approximately, the inverse of `version-to-list'. +\(Actually, it returns only one of the possible inverses, since +`version-to-list' is a many-to-one operation.)" + (if (null vlist) + "" + (let ((str-list (list "." (int-to-string (car vlist))))) + (dolist (num (cdr vlist)) + (cond + ((>= num 0) + (push (int-to-string num) str-list) + (push "." str-list)) + ((< num -3) + (error "Invalid version list `%s'" vlist)) + (t + ;; pre, or beta, or alpha + (cond ((equal "." (car str-list)) + (pop str-list)) + ((not (string-match "[0-9]+" (car str-list))) + (error "Invalid version list `%s'" vlist))) + (push (cond ((= num -1) "pre") + ((= num -2) "beta") + ((= num -3) "alpha")) + str-list)))) + (if (equal "." (car str-list)) + (pop str-list)) + (apply 'concat (nreverse str-list))))) + +(defun package-strip-version (dirname) + "Strip the version from a combined package name and version. +E.g., if given \"quux-23.0\", will return \"quux\"" + (if (string-match (concat "\\`" package-subdirectory-regexp "\\'") dirname) + (match-string 1 dirname))) + +(defun package-load-descriptor (dir package) + "Load the description file in directory DIR for package PACKAGE. +Here, PACKAGE is a string of the form NAME-VERSION, where NAME is +the package name and VERSION is its version." + (let* ((pkg-dir (expand-file-name package dir)) + (pkg-file (expand-file-name + (concat (package-strip-version package) "-pkg") + pkg-dir))) + (when (and (file-directory-p pkg-dir) + (file-exists-p (concat pkg-file ".el"))) + (load pkg-file nil t)))) + +(defun package-load-all-descriptors () + "Load descriptors for installed Emacs Lisp packages. +This looks for package subdirectories in `package-user-dir' and +`package-directory-list'. The variable `package-load-list' +controls which package subdirectories may be loaded. + +In each valid package subdirectory, this function loads the +description file containing a call to `define-package', which +updates `package-alist' and `package-obsolete-alist'." + (let ((regexp (concat "\\`" package-subdirectory-regexp "\\'"))) + (dolist (dir (cons package-user-dir package-directory-list)) + (when (file-directory-p dir) + (dolist (subdir (directory-files dir)) + (when (string-match regexp subdir) + (package-maybe-load-descriptor (match-string 1 subdir) + (match-string 2 subdir) + dir))))))) + +(defun package-maybe-load-descriptor (name version dir) + "Maybe load a specific package from directory DIR. +NAME and VERSION are the package's name and version strings. +This function checks `package-load-list', before actually loading +the package by calling `package-load-descriptor'." + (let ((force (assq (intern name) package-load-list)) + (subdir (concat name "-" version))) + (and (file-directory-p (expand-file-name subdir dir)) + ;; Check `package-load-list': + (cond ((null force) + (memq 'all package-load-list)) + ((null (setq force (cadr force))) + nil) ; disabled + ((eq force t) + t) + ((stringp force) ; held + (version-list-= (version-to-list version) + (version-to-list force))) + (t + (error "Invalid element in `package-load-list'"))) + ;; Actually load the descriptor: + (package-load-descriptor dir subdir)))) + +(defsubst package-desc-vers (desc) + "Extract version from a package description vector." + (aref desc 0)) + +(defsubst package-desc-reqs (desc) + "Extract requirements from a package description vector." + (aref desc 1)) + +(defsubst package-desc-doc (desc) + "Extract doc string from a package description vector." + (aref desc 2)) + +(defsubst package-desc-kind (desc) + "Extract the kind of download from an archive package description vector." + (aref desc 3)) + +(defun package--dir (name version) + "Return the directory where a package is installed, or nil if none. +NAME and VERSION are both strings." + (let* ((subdir (concat name "-" version)) + (dir-list (cons package-user-dir package-directory-list)) + pkg-dir) + (while dir-list + (let ((subdir-full (expand-file-name subdir (car dir-list)))) + (if (file-directory-p subdir-full) + (setq pkg-dir subdir-full + dir-list nil) + (setq dir-list (cdr dir-list))))) + pkg-dir)) + +(defun package-activate-1 (package pkg-vec) + (let* ((name (symbol-name package)) + (version-str (package-version-join (package-desc-vers pkg-vec))) + (pkg-dir (package--dir name version-str))) + (unless pkg-dir + (error "Internal error: unable to find directory for `%s-%s'" + name version-str)) + ;; Add info node. + (when (file-exists-p (expand-file-name "dir" pkg-dir)) + ;; FIXME: not the friendliest, but simple. + (require 'info) + (info-initialize) + (push pkg-dir Info-directory-list)) + ;; Add to load path, add autoloads, and activate the package. + (push pkg-dir load-path) + (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t) + (push package package-activated-list) + ;; Don't return nil. + t)) + +(defun package-built-in-p (package &optional min-version) + "Return true if PACKAGE is built-in to Emacs. +Optional arg MIN-VERSION, if non-nil, should be a version list +specifying the minimum acceptable version." + (require 'finder-inf nil t) ; For `package--builtins'. + (if (eq package 'emacs) + (version-list-<= min-version (version-to-list emacs-version)) + (let ((elt (assq package package--builtins))) + (and elt (version-list-<= min-version + (package-desc-vers (cdr elt))))))) + +;; This function goes ahead and activates a newer version of a package +;; if an older one was already activated. This is not ideal; we'd at +;; least need to check to see if the package has actually been loaded, +;; and not merely activated. +(defun package-activate (package min-version) + "Activate package PACKAGE, of version MIN-VERSION or newer. +MIN-VERSION should be a version list. +If PACKAGE has any dependencies, recursively activate them. +Return nil if the package could not be activated." + (let ((pkg-vec (cdr (assq package package-alist))) + available-version found) + ;; Check if PACKAGE is available in `package-alist'. + (when pkg-vec + (setq available-version (package-desc-vers pkg-vec) + found (version-list-<= min-version available-version))) + (cond + ;; If no such package is found, maybe it's built-in. + ((null found) + (package-built-in-p package min-version)) + ;; If the package is already activated, just return t. + ((memq package package-activated-list) + t) + ;; Otherwise, proceed with activation. + (t + (let ((fail (catch 'dep-failure + ;; Activate its dependencies recursively. + (dolist (req (package-desc-reqs pkg-vec)) + (unless (package-activate (car req) (cadr req)) + (throw 'dep-failure req)))))) + (if fail + (warn "Unable to activate package `%s'. +Required package `%s-%s' is unavailable" + package (car fail) (package-version-join (cadr fail))) + ;; If all goes well, activate the package itself. + (package-activate-1 package pkg-vec))))))) + +(defun package-mark-obsolete (package pkg-vec) + "Put package on the obsolete list, if not already there." + (let ((elt (assq package package-obsolete-alist))) + (if elt + ;; If this obsolete version does not exist in the list, update + ;; it the list. + (unless (assoc (package-desc-vers pkg-vec) (cdr elt)) + (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec) + (cdr elt)))) + ;; Make a new association. + (push (cons package (list (cons (package-desc-vers pkg-vec) + pkg-vec))) + package-obsolete-alist)))) + +(defun define-package (name-string version-string + &optional docstring requirements + &rest _extra-properties) + "Define a new package. +NAME-STRING is the name of the package, as a string. +VERSION-STRING is the version of the package, as a string. +DOCSTRING is a short description of the package, a string. +REQUIREMENTS is a list of dependencies on other packages. + Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION), + where OTHER-VERSION is a string. + +EXTRA-PROPERTIES is currently unused." + (let* ((name (intern name-string)) + (version (version-to-list version-string)) + (new-pkg-desc + (cons name + (vector version + (mapcar + (lambda (elt) + (list (car elt) + (version-to-list (car (cdr elt))))) + requirements) + docstring))) + (old-pkg (assq name package-alist))) + (cond + ;; If there's no old package, just add this to `package-alist'. + ((null old-pkg) + (push new-pkg-desc package-alist)) + ((version-list-< (package-desc-vers (cdr old-pkg)) version) + ;; Remove the old package and declare it obsolete. + (package-mark-obsolete name (cdr old-pkg)) + (setq package-alist (cons new-pkg-desc + (delq old-pkg package-alist)))) + ;; You can have two packages with the same version, e.g. one in + ;; the system package directory and one in your private + ;; directory. We just let the first one win. + ((not (version-list-= (package-desc-vers (cdr old-pkg)) version)) + ;; The package is born obsolete. + (package-mark-obsolete name (cdr new-pkg-desc)))))) + +;; From Emacs 22. +(defun package-autoload-ensure-default-file (file) + "Make sure that the autoload file FILE exists and if not create it." + (unless (file-exists-p file) + (write-region + (concat ";;; " (file-name-nondirectory file) + " --- automatically extracted autoloads\n" + ";;\n" + ";;; Code:\n\n" + " \n;; Local Variables:\n" + ";; version-control: never\n" + ";; no-byte-compile: t\n" + ";; no-update-autoloads: t\n" + ";; End:\n" + ";;; " (file-name-nondirectory file) + " ends here\n") + nil file)) + file) + +(defun package-generate-autoloads (name pkg-dir) + (require 'autoload) ;Load before we let-bind generated-autoload-file! + (let* ((auto-name (concat name "-autoloads.el")) + ;;(ignore-name (concat name "-pkg.el")) + (generated-autoload-file (expand-file-name auto-name pkg-dir)) + (version-control 'never)) + (unless (fboundp 'autoload-ensure-default-file) + (package-autoload-ensure-default-file generated-autoload-file)) + (update-directory-autoloads pkg-dir) + (let ((buf (find-buffer-visiting generated-autoload-file))) + (when buf (kill-buffer buf))))) + +(defvar tar-parse-info) +(declare-function tar-untar-buffer "tar-mode" ()) +(declare-function tar-header-name "tar-mode" (tar-header)) +(declare-function tar-header-link-type "tar-mode" (tar-header)) + +(defun package-untar-buffer (dir) + "Untar the current buffer. +This uses `tar-untar-buffer' from Tar mode. All files should +untar into a directory named DIR; otherwise, signal an error." + (require 'tar-mode) + (tar-mode) + ;; Make sure everything extracts into DIR. + (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/")) + (case-fold-search (memq system-type '(windows-nt ms-dos cygwin)))) + (dolist (tar-data tar-parse-info) + (let ((name (expand-file-name (tar-header-name tar-data)))) + (or (string-match regexp name) + ;; Tarballs created by some utilities don't list + ;; directories with a trailing slash (Bug#13136). + (and (string-equal dir name) + (eq (tar-header-link-type tar-data) 5)) + (error "Package does not untar cleanly into directory %s/" dir))))) + (tar-untar-buffer)) + +(defun package-unpack (package version) + (let* ((name (symbol-name package)) + (dirname (concat name "-" version)) + (pkg-dir (expand-file-name dirname package-user-dir))) + (make-directory package-user-dir t) + ;; FIXME: should we delete PKG-DIR if it exists? + (let* ((default-directory (file-name-as-directory package-user-dir))) + (package-untar-buffer dirname) + (package--make-autoloads-and-compile name pkg-dir)))) + +(defun package--make-autoloads-and-compile (name pkg-dir) + "Generate autoloads and do byte-compilation for package named NAME. +PKG-DIR is the name of the package directory." + (package-generate-autoloads name pkg-dir) + (let ((load-path (cons pkg-dir load-path))) + ;; We must load the autoloads file before byte compiling, in + ;; case there are magic cookies to set up non-trivial paths. + (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t) + (byte-recompile-directory pkg-dir 0 t))) + +(defun package--write-file-no-coding (file-name) + (let ((buffer-file-coding-system 'no-conversion)) + (write-region (point-min) (point-max) file-name))) + +(defun package-unpack-single (file-name version desc requires) + "Install the contents of the current buffer as a package." + ;; Special case "package". + (if (string= file-name "package") + (package--write-file-no-coding + (expand-file-name (concat file-name ".el") package-user-dir)) + (let* ((pkg-dir (expand-file-name (concat file-name "-" + (package-version-join + (version-to-list version))) + package-user-dir)) + (el-file (expand-file-name (concat file-name ".el") pkg-dir)) + (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir))) + (make-directory pkg-dir t) + (package--write-file-no-coding el-file) + (let ((print-level nil) + (print-length nil)) + (write-region + (concat + (prin1-to-string + (list 'define-package + file-name + version + desc + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (cadr elt)))) + requires)))) + "\n") + nil + pkg-file + nil nil nil 'excl)) + (package--make-autoloads-and-compile file-name pkg-dir)))) + +(defmacro package--with-work-buffer (location file &rest body) + "Run BODY in a buffer containing the contents of FILE at LOCATION. +LOCATION is the base location of a package archive, and should be +one of the URLs (or file names) specified in `package-archives'. +FILE is the name of a file relative to that base location. + +This macro retrieves FILE from LOCATION into a temporary buffer, +and evaluates BODY while that buffer is current. This work +buffer is killed afterwards. Return the last value in BODY." + `(let* ((http (string-match "\\`https?:" ,location)) + (buffer + (if http + (url-retrieve-synchronously (concat ,location ,file)) + (generate-new-buffer "*package work buffer*")))) + (prog1 + (with-current-buffer buffer + (if http + (progn (package-handle-response) + (re-search-forward "^$" nil 'move) + (forward-char) + (delete-region (point-min) (point))) + (unless (file-name-absolute-p ,location) + (error "Archive location %s is not an absolute file name" + ,location)) + (insert-file-contents (expand-file-name ,file ,location))) + ,@body) + (kill-buffer buffer)))) + +(defun package-handle-response () + "Handle the response from a `url-retrieve-synchronously' call. +Parse the HTTP response and throw if an error occurred. +The url package seems to require extra processing for this. +This should be called in a `save-excursion', in the download buffer. +It will move point to somewhere in the headers." + ;; We assume HTTP here. + (require 'url-http) + (let ((response (url-http-parse-response))) + (when (or (< response 200) (>= response 300)) + (error "Error during download request:%s" + (buffer-substring-no-properties (point) (progn + (end-of-line) + (point))))))) + +(defun package-download-single (name version desc requires) + "Download and install a single-file package." + (let ((location (package-archive-base name)) + (file (concat (symbol-name name) "-" version ".el"))) + (package--with-work-buffer location file + (package-unpack-single (symbol-name name) version desc requires)))) + +(defun package-download-tar (name version) + "Download and install a tar package." + (let ((location (package-archive-base name)) + (file (concat (symbol-name name) "-" version ".tar"))) + (package--with-work-buffer location file + (package-unpack name version)))) + +(defun package-installed-p (package &optional min-version) + "Return true if PACKAGE, of MIN-VERSION or newer, is installed. +MIN-VERSION should be a version list." + (unless package--initialized (error "package.el is not yet initialized!")) + (let ((pkg-desc (assq package package-alist))) + (if pkg-desc + (version-list-<= min-version + (package-desc-vers (cdr pkg-desc))) + ;; Also check built-in packages. + (package-built-in-p package min-version)))) + +(defun package-compute-transaction (package-list requirements) + "Return a list of packages to be installed, including PACKAGE-LIST. +PACKAGE-LIST should be a list of package names (symbols). + +REQUIREMENTS should be a list of additional requirements; each +element in this list should have the form (PACKAGE VERSION-LIST), +where PACKAGE is a package name and VERSION-LIST is the required +version of that package. + +This function recursively computes the requirements of the +packages in REQUIREMENTS, and returns a list of all the packages +that must be installed. Packages that are already installed are +not included in this list." + (dolist (elt requirements) + (let* ((next-pkg (car elt)) + (next-version (cadr elt))) + (unless (package-installed-p next-pkg next-version) + ;; A package is required, but not installed. It might also be + ;; blocked via `package-load-list'. + (let ((pkg-desc (assq next-pkg package-archive-contents)) + hold) + (when (setq hold (assq next-pkg package-load-list)) + (setq hold (cadr hold)) + (cond ((eq hold t)) + ((eq hold nil) + (error "Required package '%s' is disabled" + (symbol-name next-pkg))) + ((null (stringp hold)) + (error "Invalid element in `package-load-list'")) + ((version-list-< (version-to-list hold) next-version) + (error "Package `%s' held at version %s, \ +but version %s required" + (symbol-name next-pkg) hold + (package-version-join next-version))))) + (unless pkg-desc + (error "Package `%s-%s' is unavailable" + (symbol-name next-pkg) + (package-version-join next-version))) + (unless (version-list-<= next-version + (package-desc-vers (cdr pkg-desc))) + (error + "Need package `%s-%s', but only %s is available" + (symbol-name next-pkg) (package-version-join next-version) + (package-version-join (package-desc-vers (cdr pkg-desc))))) + ;; Only add to the transaction if we don't already have it. + (unless (memq next-pkg package-list) + (push next-pkg package-list)) + (setq package-list + (package-compute-transaction package-list + (package-desc-reqs + (cdr pkg-desc)))))))) + package-list) + +(defun package-read-from-string (str) + "Read a Lisp expression from STR. +Signal an error if the entire string was not used." + (let* ((read-data (read-from-string str)) + (more-left + (condition-case nil + ;; The call to `ignore' suppresses a compiler warning. + (progn (ignore (read-from-string + (substring str (cdr read-data)))) + t) + (end-of-file nil)))) + (if more-left + (error "Can't read whole string") + (car read-data)))) + +(defun package--read-archive-file (file) + "Re-read archive file FILE, if it exists. +Will return the data from the file, or nil if the file does not exist. +Will throw an error if the archive version is too new." + (let ((filename (expand-file-name file package-user-dir))) + (when (file-exists-p filename) + (with-temp-buffer + (insert-file-contents-literally filename) + (let ((contents (read (current-buffer)))) + (if (> (car contents) package-archive-version) + (error "Package archive version %d is higher than %d" + (car contents) package-archive-version)) + (cdr contents)))))) + +(defun package-read-all-archive-contents () + "Re-read `archive-contents', if it exists. +If successful, set `package-archive-contents'." + (setq package-archive-contents nil) + (dolist (archive package-archives) + (package-read-archive-contents (car archive)))) + +(defun package-read-archive-contents (archive) + "Re-read archive contents for ARCHIVE. +If successful, set the variable `package-archive-contents'. +If the archive version is too new, signal an error." + ;; Version 1 of 'archive-contents' is identical to our internal + ;; representation. + (let* ((dir (concat "archives/" archive)) + (contents-file (concat dir "/archive-contents")) + contents) + (when (setq contents (package--read-archive-file contents-file)) + (dolist (package contents) + (package--add-to-archive-contents package archive))))) + +(defun package--add-to-archive-contents (package archive) + "Add the PACKAGE from the given ARCHIVE if necessary. +Also, add the originating archive to the end of the package vector." + (let* ((name (car package)) + (version (package-desc-vers (cdr package))) + (entry (cons name + (vconcat (cdr package) (vector archive)))) + (existing-package (assq name package-archive-contents))) + (cond ((not existing-package) + (add-to-list 'package-archive-contents entry)) + ((version-list-< (package-desc-vers (cdr existing-package)) + version) + ;; Replace the entry with this one. + (setq package-archive-contents + (cons entry + (delq existing-package + package-archive-contents))))))) + +(defun package-download-transaction (package-list) + "Download and install all the packages in PACKAGE-LIST. +PACKAGE-LIST should be a list of package names (symbols). +This function assumes that all package requirements in +PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed +using `package-compute-transaction'." + (dolist (elt package-list) + (let* ((desc (cdr (assq elt package-archive-contents))) + ;; As an exception, if package is "held" in + ;; `package-load-list', download the held version. + (hold (cadr (assq elt package-load-list))) + (v-string (or (and (stringp hold) hold) + (package-version-join (package-desc-vers desc)))) + (kind (package-desc-kind desc))) + (cond + ((eq kind 'tar) + (package-download-tar elt v-string)) + ((eq kind 'single) + (package-download-single elt v-string + (package-desc-doc desc) + (package-desc-reqs desc))) + (t + (error "Unknown package kind: %s" (symbol-name kind)))) + ;; If package A depends on package B, then A may `require' B + ;; during byte compilation. So we need to activate B before + ;; unpacking A. + (package-maybe-load-descriptor (symbol-name elt) v-string + package-user-dir) + (package-activate elt (version-to-list v-string))))) + +(defvar package--initialized nil) + +;;;###autoload +(defun package-install (name) + "Install the package named NAME. +NAME should be the name of one of the available packages in an +archive in `package-archives'. Interactively, prompt for NAME." + (interactive + (progn + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (unless package--initialized + (package-initialize t)) + (unless package-archive-contents + (package-refresh-contents)) + (list (intern (completing-read + "Install package: " + (mapcar (lambda (elt) + (cons (symbol-name (car elt)) + nil)) + package-archive-contents) + nil t))))) + (let ((pkg-desc (assq name package-archive-contents))) + (unless pkg-desc + (error "Package `%s' is not available for installation" + (symbol-name name))) + (package-download-transaction + (package-compute-transaction (list name) + (package-desc-reqs (cdr pkg-desc)))))) + +(defun package-strip-rcs-id (str) + "Strip RCS version ID from the version string STR. +If the result looks like a dotted numeric version, return it. +Otherwise return nil." + (when str + (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str) + (setq str (substring str (match-end 0)))) + (condition-case nil + (if (version-to-list str) + str) + (error nil)))) + +(defun package-buffer-info () + "Return a vector describing the package in the current buffer. +The vector has the form + + [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY] + +FILENAME is the file name, a string, sans the \".el\" extension. +REQUIRES is a list of requirements, each requirement having the + form (NAME VER); NAME is a string and VER is a version list. +DESCRIPTION is the package description, a string. +VERSION is the version, a string. +COMMENTARY is the commentary section, a string, or nil if none. + +If the buffer does not contain a conforming package, signal an +error. If there is a package, narrow the buffer to the file's +boundaries." + (goto-char (point-min)) + (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t) + (error "Packages lacks a file header")) + (let ((file-name (match-string-no-properties 1)) + (desc (match-string-no-properties 2)) + (start (line-beginning-position))) + (unless (search-forward (concat ";;; " file-name ".el ends here")) + (error "Package lacks a terminating comment")) + ;; Try to include a trailing newline. + (forward-line) + (narrow-to-region start (point)) + (require 'lisp-mnt) + ;; Use some headers we've invented to drive the process. + (let* ((requires-str (lm-header "package-requires")) + (requires (if requires-str + (package-read-from-string requires-str))) + ;; Prefer Package-Version; if defined, the package author + ;; probably wants us to use it. Otherwise try Version. + (pkg-version + (or (package-strip-rcs-id (lm-header "package-version")) + (package-strip-rcs-id (lm-header "version")))) + (commentary (lm-commentary))) + (unless pkg-version + (error + "Package lacks a \"Version\" or \"Package-Version\" header")) + ;; Turn string version numbers into list form. + (setq requires + (mapcar + (lambda (elt) + (list (car elt) + (version-to-list (car (cdr elt))))) + requires)) + (vector file-name requires desc pkg-version commentary)))) + +(defun package-tar-file-info (file) + "Find package information for a tar file. +FILE is the name of the tar file to examine. +The return result is a vector like `package-buffer-info'." + (let ((default-directory (file-name-directory file)) + (file (file-name-nondirectory file))) + (unless (string-match (concat "\\`" package-subdirectory-regexp "\\.tar\\'") + file) + (error "Invalid package name `%s'" file)) + (let* ((pkg-name (match-string-no-properties 1 file)) + (pkg-version (match-string-no-properties 2 file)) + ;; Extract the package descriptor. + (pkg-def-contents (shell-command-to-string + ;; Requires GNU tar. + (concat "tar -xOf " file " " + + pkg-name "-" pkg-version "/" + pkg-name "-pkg.el"))) + (pkg-def-parsed (package-read-from-string pkg-def-contents))) + (unless (eq (car pkg-def-parsed) 'define-package) + (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name)) + (let ((name-str (nth 1 pkg-def-parsed)) + (version-string (nth 2 pkg-def-parsed)) + (docstring (nth 3 pkg-def-parsed)) + (requires (nth 4 pkg-def-parsed)) + (readme (shell-command-to-string + ;; Requires GNU tar. + (concat "tar -xOf " file " " + pkg-name "-" pkg-version "/README")))) + (unless (equal pkg-version version-string) + (error "Package has inconsistent versions")) + (unless (equal pkg-name name-str) + (error "Package has inconsistent names")) + ;; Kind of a hack. + (if (string-match ": Not found in archive" readme) + (setq readme nil)) + ;; Turn string version numbers into list form. + (if (eq (car requires) 'quote) + (setq requires (car (cdr requires)))) + (setq requires + (mapcar (lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) + requires)) + (vector pkg-name requires docstring version-string readme))))) + +;;;###autoload +(defun package-install-from-buffer (pkg-info type) + "Install a package from the current buffer. +When called interactively, the current buffer is assumed to be a +single .el file that follows the packaging guidelines; see info +node `(elisp)Packaging'. + +When called from Lisp, PKG-INFO is a vector describing the +information, of the type returned by `package-buffer-info'; and +TYPE is the package type (either `single' or `tar')." + (interactive (list (package-buffer-info) 'single)) + (save-excursion + (save-restriction + (let* ((file-name (aref pkg-info 0)) + (requires (aref pkg-info 1)) + (desc (if (string= (aref pkg-info 2) "") + "No description available." + (aref pkg-info 2))) + (pkg-version (aref pkg-info 3))) + ;; Download and install the dependencies. + (let ((transaction (package-compute-transaction nil requires))) + (package-download-transaction transaction)) + ;; Install the package itself. + (cond + ((eq type 'single) + (package-unpack-single file-name pkg-version desc requires)) + ((eq type 'tar) + (package-unpack (intern file-name) pkg-version)) + (t + (error "Unknown type: %s" (symbol-name type)))) + ;; Try to activate it. + (package-initialize))))) + +;;;###autoload +(defun package-install-file (file) + "Install a package from a file. +The file can either be a tar file or an Emacs Lisp file." + (interactive "fPackage file name: ") + (with-temp-buffer + (insert-file-contents-literally file) + (cond + ((string-match "\\.el$" file) + (package-install-from-buffer (package-buffer-info) 'single)) + ((string-match "\\.tar$" file) + (package-install-from-buffer (package-tar-file-info file) 'tar)) + (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) + +(defun package-delete (name version) + (let ((dir (package--dir name version))) + (if (string-equal (file-name-directory dir) + (file-name-as-directory + (expand-file-name package-user-dir))) + (progn + (delete-directory dir t t) + (message "Package `%s-%s' deleted." name version)) + ;; Don't delete "system" packages + (error "Package `%s-%s' is a system package, not deleting" + name version)))) + +(defun package-archive-base (name) + "Return the archive containing the package NAME." + (let ((desc (cdr (assq (intern-soft name) package-archive-contents)))) + (cdr (assoc (aref desc (- (length desc) 1)) package-archives)))) + +(defun package--download-one-archive (archive file) + "Retrieve an archive file FILE from ARCHIVE, and cache it. +ARCHIVE should be a cons cell of the form (NAME . LOCATION), +similar to an entry in `package-alist'. Save the cached copy to +\"archives/NAME/archive-contents\" in `package-user-dir'." + (let* ((dir (expand-file-name "archives" package-user-dir)) + (dir (expand-file-name (car archive) dir))) + (package--with-work-buffer (cdr archive) file + ;; Read the retrieved buffer to make sure it is valid (e.g. it + ;; may fetch a URL redirect page). + (when (listp (read buffer)) + (make-directory dir t) + (setq buffer-file-name (expand-file-name file dir)) + (let ((version-control 'never)) + (save-buffer)))))) + +;;;###autoload +(defun package-refresh-contents () + "Download the ELPA archive description if needed. +This informs Emacs about the latest versions of all packages, and +makes them available for download." + (interactive) + (unless (file-exists-p package-user-dir) + (make-directory package-user-dir t)) + (dolist (archive package-archives) + (condition-case-unless-debug nil + (package--download-one-archive archive "archive-contents") + (error (message "Failed to download `%s' archive." + (car archive))))) + (package-read-all-archive-contents)) + +;;;###autoload +(defun package-initialize (&optional no-activate) + "Load Emacs Lisp packages, and activate them. +The variable `package-load-list' controls which packages to load. +If optional arg NO-ACTIVATE is non-nil, don't activate packages." + (interactive) + (setq package-alist nil + package-obsolete-alist nil) + (package-load-all-descriptors) + (package-read-all-archive-contents) + (unless no-activate + (dolist (elt package-alist) + (package-activate (car elt) (package-desc-vers (cdr elt))))) + (setq package--initialized t)) + + +;;;; Package description buffer. + +;;;###autoload +(defun describe-package (package) + "Display the full documentation of PACKAGE (a symbol)." + (interactive + (let* ((guess (function-called-at-point)) + packages val) + (require 'finder-inf nil t) + ;; Load the package list if necessary (but don't activate them). + (unless package--initialized + (package-initialize t)) + (setq packages (append (mapcar 'car package-alist) + (mapcar 'car package-archive-contents) + (mapcar 'car package--builtins))) + (unless (memq guess packages) + (setq guess nil)) + (setq packages (mapcar 'symbol-name packages)) + (setq val + (completing-read (if guess + (format "Describe package (default %s): " + guess) + "Describe package: ") + packages nil t nil nil guess)) + (list (if (equal val "") guess (intern val))))) + (if (or (null package) (not (symbolp package))) + (message "No package specified") + (help-setup-xref (list #'describe-package package) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (describe-package-1 package))))) + +(defun describe-package-1 (package) + (require 'lisp-mnt) + (let ((package-name (symbol-name package)) + (built-in (assq package package--builtins)) + desc pkg-dir reqs version installable) + (prin1 package) + (princ " is ") + (cond + ;; Loaded packages are in `package-alist'. + ((setq desc (cdr (assq package package-alist))) + (setq version (package-version-join (package-desc-vers desc))) + (if (setq pkg-dir (package--dir package-name version)) + (insert "an installed package.\n\n") + ;; This normally does not happen. + (insert "a deleted package.\n\n"))) + ;; Available packages are in `package-archive-contents'. + ((setq desc (cdr (assq package package-archive-contents))) + (setq version (package-version-join (package-desc-vers desc)) + installable t) + (if built-in + (insert "a built-in package.\n\n") + (insert "an uninstalled package.\n\n"))) + (built-in + (setq desc (cdr built-in) + version (package-version-join (package-desc-vers desc))) + (insert "a built-in package.\n\n")) + (t + (insert "an orphan package.\n\n"))) + + (insert " " (propertize "Status" 'font-lock-face 'bold) ": ") + (cond (pkg-dir + (insert (propertize "Installed" + 'font-lock-face 'font-lock-comment-face)) + (insert " in `") + ;; Todo: Add button for uninstalling. + (help-insert-xref-button (file-name-as-directory pkg-dir) + 'help-package-def pkg-dir) + (if built-in + (insert "',\n shadowing a " + (propertize "built-in package" + 'font-lock-face 'font-lock-builtin-face) + ".") + (insert "'."))) + (installable + (if built-in + (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face) + " Alternate version available -- ") + (insert "Available -- ")) + (let ((button-text (if (display-graphic-p) "Install" "[Install]")) + (button-face (if (display-graphic-p) + '(:box (:line-width 2 :color "dark grey") + :background "light grey" + :foreground "black") + 'link))) + (insert-text-button button-text 'face button-face 'follow-link t + 'package-symbol package + 'action 'package-install-button-action))) + (built-in + (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face))) + (t (insert "Deleted."))) + (insert "\n") + (and version (> (length version) 0) + (insert " " + (propertize "Version" 'font-lock-face 'bold) ": " version "\n")) + + (setq reqs (if desc (package-desc-reqs desc))) + (when reqs + (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ") + (let ((first t) + name vers text) + (dolist (req reqs) + (setq name (car req) + vers (cadr req) + text (format "%s-%s" (symbol-name name) + (package-version-join vers))) + (cond (first (setq first nil)) + ((>= (+ 2 (current-column) (length text)) + (window-width)) + (insert ",\n ")) + (t (insert ", "))) + (help-insert-xref-button text 'help-package name)) + (insert "\n"))) + (insert " " (propertize "Summary" 'font-lock-face 'bold) + ": " (if desc (package-desc-doc desc)) "\n\n") + + (if built-in + ;; For built-in packages, insert the commentary. + (let ((fn (locate-file (concat package-name ".el") load-path + load-file-rep-suffixes)) + (opoint (point))) + (insert (or (lm-commentary fn) "")) + (save-excursion + (goto-char opoint) + (when (re-search-forward "^;;; Commentary:\n" nil t) + (replace-match "")) + (while (re-search-forward "^\\(;+ ?\\)" nil t) + (replace-match "")))) + (let ((readme (expand-file-name (concat package-name "-readme.txt") + package-user-dir)) + readme-string) + ;; For elpa packages, try downloading the commentary. If that + ;; fails, try an existing readme file in `package-user-dir'. + (cond ((condition-case nil + (package--with-work-buffer (package-archive-base package) + (concat package-name "-readme.txt") + (setq buffer-file-name + (expand-file-name readme package-user-dir)) + (let ((version-control 'never)) + (save-buffer)) + (setq readme-string (buffer-string)) + t) + (error nil)) + (insert readme-string)) + ((file-readable-p readme) + (insert-file-contents readme) + (goto-char (point-max)))))))) + +(defun package-install-button-action (button) + (let ((package (button-get button 'package-symbol))) + (when (y-or-n-p (format "Install package `%s'? " package)) + (package-install package) + (revert-buffer nil t) + (goto-char (point-min))))) + + +;;;; Package menu mode. + +(defvar package-menu-mode-map + (let ((map (make-sparse-keymap)) + (menu-map (make-sparse-keymap "Package"))) + (set-keymap-parent map tabulated-list-mode-map) + (define-key map "\C-m" 'package-menu-describe-package) + (define-key map "u" 'package-menu-mark-unmark) + (define-key map "\177" 'package-menu-backup-unmark) + (define-key map "d" 'package-menu-mark-delete) + (define-key map "i" 'package-menu-mark-install) + (define-key map "U" 'package-menu-mark-upgrades) + (define-key map "r" 'package-menu-refresh) + (define-key map "~" 'package-menu-mark-obsolete-for-deletion) + (define-key map "x" 'package-menu-execute) + (define-key map "h" 'package-menu-quick-help) + (define-key map "?" 'package-menu-describe-package) + (define-key map [menu-bar package-menu] (cons "Package" menu-map)) + (define-key menu-map [mq] + '(menu-item "Quit" quit-window + :help "Quit package selection")) + (define-key menu-map [s1] '("--")) + (define-key menu-map [mn] + '(menu-item "Next" next-line + :help "Next Line")) + (define-key menu-map [mp] + '(menu-item "Previous" previous-line + :help "Previous Line")) + (define-key menu-map [s2] '("--")) + (define-key menu-map [mu] + '(menu-item "Unmark" package-menu-mark-unmark + :help "Clear any marks on a package and move to the next line")) + (define-key menu-map [munm] + '(menu-item "Unmark Backwards" package-menu-backup-unmark + :help "Back up one line and clear any marks on that package")) + (define-key menu-map [md] + '(menu-item "Mark for Deletion" package-menu-mark-delete + :help "Mark a package for deletion and move to the next line")) + (define-key menu-map [mi] + '(menu-item "Mark for Install" package-menu-mark-install + :help "Mark a package for installation and move to the next line")) + (define-key menu-map [mupgrades] + '(menu-item "Mark Upgradable Packages" package-menu-mark-upgrades + :help "Mark packages that have a newer version for upgrading")) + (define-key menu-map [s3] '("--")) + (define-key menu-map [mg] + '(menu-item "Update Package List" revert-buffer + :help "Update the list of packages")) + (define-key menu-map [mr] + '(menu-item "Refresh Package List" package-menu-refresh + :help "Download the ELPA archive")) + (define-key menu-map [s4] '("--")) + (define-key menu-map [mt] + '(menu-item "Mark Obsolete Packages" package-menu-mark-obsolete-for-deletion + :help "Mark all obsolete packages for deletion")) + (define-key menu-map [mx] + '(menu-item "Execute Actions" package-menu-execute + :help "Perform all the marked actions")) + (define-key menu-map [s5] '("--")) + (define-key menu-map [mh] + '(menu-item "Help" package-menu-quick-help + :help "Show short key binding help for package-menu-mode")) + (define-key menu-map [mc] + '(menu-item "View Commentary" package-menu-view-commentary + :help "Display information about this package")) + map) + "Local keymap for `package-menu-mode' buffers.") + +(defvar package-menu--new-package-list nil + "List of newly-available packages since `list-packages' was last called.") + +(define-derived-mode package-menu-mode tabulated-list-mode "Package Menu" + "Major mode for browsing a list of packages. +Letters do not insert themselves; instead, they are commands. +\\<package-menu-mode-map> +\\{package-menu-mode-map}" + (setq tabulated-list-format [("Package" 18 package-menu--name-predicate) + ("Version" 12 nil) + ("Status" 10 package-menu--status-predicate) + ("Description" 0 nil)]) + (setq tabulated-list-padding 2) + (setq tabulated-list-sort-key (cons "Status" nil)) + (tabulated-list-init-header)) + +(defmacro package--push (package desc status listname) + "Convenience macro for `package-menu--generate'. +If the alist stored in the symbol LISTNAME lacks an entry for a +package PACKAGE with descriptor DESC, add one. The alist is +keyed with cons cells (PACKAGE . VERSION-LIST), where PACKAGE is +a symbol and VERSION-LIST is a version list." + `(let* ((version (package-desc-vers ,desc)) + (key (cons ,package version))) + (unless (assoc key ,listname) + (push (list key ,status (package-desc-doc ,desc)) ,listname)))) + +(defun package-menu--generate (remember-pos packages) + "Populate the Package Menu. +If REMEMBER-POS is non-nil, keep point on the same entry. +PACKAGES should be t, which means to display all known packages, +or a list of package names (symbols) to display." + ;; Construct list of ((PACKAGE . VERSION) STATUS DESCRIPTION). + (let (info-list name) + ;; Installed packages: + (dolist (elt package-alist) + (setq name (car elt)) + (when (or (eq packages t) (memq name packages)) + (package--push name (cdr elt) + (if (stringp (cadr (assq name package-load-list))) + "held" "installed") + info-list))) + + ;; Built-in packages: + (dolist (elt package--builtins) + (setq name (car elt)) + (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. + (or (eq packages t) (memq name packages))) + (package--push name (cdr elt) "built-in" info-list))) + + ;; Available and disabled packages: + (dolist (elt package-archive-contents) + (setq name (car elt)) + (when (or (eq packages t) (memq name packages)) + (let ((hold (assq name package-load-list))) + (package--push name (cdr elt) + (cond + ((and hold (null (cadr hold))) "disabled") + ((memq name package-menu--new-package-list) "new") + (t "available")) + info-list)))) + + ;; Obsolete packages: + (dolist (elt package-obsolete-alist) + (dolist (inner-elt (cdr elt)) + (when (or (eq packages t) (memq (car elt) packages)) + (package--push (car elt) (cdr inner-elt) "obsolete" info-list)))) + + ;; Print the result. + (setq tabulated-list-entries (mapcar 'package-menu--print-info info-list)) + (tabulated-list-print remember-pos))) + +(defun package-menu--print-info (pkg) + "Return a package entry suitable for `tabulated-list-entries'. +PKG has the form ((PACKAGE . VERSION) STATUS DOC). +Return (KEY [NAME VERSION STATUS DOC]), where KEY is the +identifier (NAME . VERSION-LIST)." + (let* ((package (caar pkg)) + (version (cdr (car pkg))) + (status (nth 1 pkg)) + (doc (or (nth 2 pkg) "")) + (face (cond + ((string= status "built-in") 'font-lock-builtin-face) + ((string= status "available") 'default) + ((string= status "new") 'bold) + ((string= status "held") 'font-lock-constant-face) + ((string= status "disabled") 'font-lock-warning-face) + ((string= status "installed") 'font-lock-comment-face) + (t 'font-lock-warning-face)))) ; obsolete. + (list (cons package version) + (vector (list (symbol-name package) + 'face 'link + 'follow-link t + 'package-symbol package + 'action 'package-menu-describe-package) + (propertize (package-version-join version) + 'font-lock-face face) + (propertize status 'font-lock-face face) + (propertize doc 'font-lock-face face))))) + +(defun package-menu-refresh () + "Download the Emacs Lisp package archive. +This fetches the contents of each archive specified in +`package-archives', and then refreshes the package menu." + (interactive) + (unless (derived-mode-p 'package-menu-mode) + (error "The current buffer is not a Package Menu")) + (package-refresh-contents) + (package-menu--generate t t)) + +(defun package-menu-describe-package (&optional button) + "Describe the current package. +If optional arg BUTTON is non-nil, describe its associated package." + (interactive) + (let ((package (if button (button-get button 'package-symbol) + (car (tabulated-list-get-id))))) + (if package + (describe-package package)))) + +;; fixme numeric argument +(defun package-menu-mark-delete (&optional _num) + "Mark a package for deletion and move to the next line." + (interactive "p") + (if (member (package-menu-get-status) '("installed" "obsolete")) + (tabulated-list-put-tag "D" t) + (forward-line))) + +(defun package-menu-mark-install (&optional _num) + "Mark a package for installation and move to the next line." + (interactive "p") + (if (member (package-menu-get-status) '("available" "new")) + (tabulated-list-put-tag "I" t) + (forward-line))) + +(defun package-menu-mark-unmark (&optional _num) + "Clear any marks on a package and move to the next line." + (interactive "p") + (tabulated-list-put-tag " " t)) + +(defun package-menu-backup-unmark () + "Back up one line and clear any marks on that package." + (interactive) + (forward-line -1) + (tabulated-list-put-tag " ")) + +(defun package-menu-mark-obsolete-for-deletion () + "Mark all obsolete packages for deletion." + (interactive) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (if (equal (package-menu-get-status) "obsolete") + (tabulated-list-put-tag "D" t) + (forward-line 1))))) + +(defun package-menu-quick-help () + "Show short key binding help for package-menu-mode." + (interactive) + (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp")) + +(define-obsolete-function-alias + 'package-menu-view-commentary 'package-menu-describe-package "24.1") + +(defun package-menu-get-status () + (let* ((pkg (tabulated-list-get-id)) + (entry (and pkg (assq pkg tabulated-list-entries)))) + (if entry + (aref (cadr entry) 2) + ""))) + +(defun package-menu--find-upgrades () + (let (installed available upgrades) + ;; Build list of installed/available packages in this buffer. + (dolist (entry tabulated-list-entries) + ;; ENTRY is ((NAME . VERSION) [NAME VERSION STATUS DOC]) + (let ((pkg (car entry)) + (status (aref (cadr entry) 2))) + (cond ((equal status "installed") + (push pkg installed)) + ((member status '("available" "new")) + (push pkg available))))) + ;; Loop through list of installed packages, finding upgrades + (dolist (pkg installed) + (let ((avail-pkg (assq (car pkg) available))) + (and avail-pkg + (version-list-< (cdr pkg) (cdr avail-pkg)) + (push avail-pkg upgrades)))) + upgrades)) + +(defun package-menu-mark-upgrades () + "Mark all upgradable packages in the Package Menu. +For each installed package with a newer version available, place +an (I)nstall flag on the available version and a (D)elete flag on +the installed version. A subsequent \\[package-menu-execute] +call will upgrade the package." + (interactive) + (unless (derived-mode-p 'package-menu-mode) + (error "The current buffer is not a Package Menu")) + (let ((upgrades (package-menu--find-upgrades))) + (if (null upgrades) + (message "No packages to upgrade.") + (widen) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (let* ((pkg (tabulated-list-get-id)) + (upgrade (assq (car pkg) upgrades))) + (cond ((null upgrade) + (forward-line 1)) + ((equal pkg upgrade) + (package-menu-mark-install)) + (t + (package-menu-mark-delete)))))) + (message "%d package%s marked for upgrading." + (length upgrades) + (if (= (length upgrades) 1) "" "s"))))) + +(defun package-menu-execute () + "Perform marked Package Menu actions. +Packages marked for installation are downloaded and installed; +packages marked for deletion are removed." + (interactive) + (unless (derived-mode-p 'package-menu-mode) + (error "The current buffer is not in Package Menu mode")) + (let (install-list delete-list cmd id) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (setq cmd (char-after)) + (unless (eq cmd ?\s) + ;; This is the key (PACKAGE . VERSION-LIST). + (setq id (tabulated-list-get-id)) + (cond ((eq cmd ?D) + (push (cons (symbol-name (car id)) + (package-version-join (cdr id))) + delete-list)) + ((eq cmd ?I) + (push (car id) install-list)))) + (forward-line))) + (when install-list + (if (yes-or-no-p + (if (= (length install-list) 1) + (format "Install package `%s'? " (car install-list)) + (format "Install these %d packages (%s)? " + (length install-list) + (mapconcat 'symbol-name install-list ", ")))) + (mapc 'package-install install-list))) + ;; Delete packages, prompting if necessary. + (when delete-list + (if (yes-or-no-p + (if (= (length delete-list) 1) + (format "Delete package `%s-%s'? " + (caar delete-list) + (cdr (car delete-list))) + (format "Delete these %d packages (%s)? " + (length delete-list) + (mapconcat (lambda (elt) + (concat (car elt) "-" (cdr elt))) + delete-list + ", ")))) + (dolist (elt delete-list) + (condition-case-unless-debug err + (package-delete (car elt) (cdr elt)) + (error (message (cadr err))))) + (error "Aborted"))) + ;; If we deleted anything, regenerate `package-alist'. This is done + ;; automatically if we installed a package. + (and delete-list (null install-list) + (package-initialize)) + (if (or delete-list install-list) + (package-menu--generate t t) + (message "No operations specified.")))) + +(defun package-menu--version-predicate (A B) + (let ((vA (or (aref (cadr A) 1) '(0))) + (vB (or (aref (cadr B) 1) '(0)))) + (if (version-list-= vA vB) + (package-menu--name-predicate A B) + (version-list-< vA vB)))) + +(defun package-menu--status-predicate (A B) + (let ((sA (aref (cadr A) 2)) + (sB (aref (cadr B) 2))) + (cond ((string= sA sB) + (package-menu--name-predicate A B)) + ((string= sA "new") t) + ((string= sB "new") nil) + ((string= sA "available") t) + ((string= sB "available") nil) + ((string= sA "installed") t) + ((string= sB "installed") nil) + ((string= sA "held") t) + ((string= sB "held") nil) + ((string= sA "built-in") t) + ((string= sB "built-in") nil) + ((string= sA "obsolete") t) + ((string= sB "obsolete") nil) + (t (string< sA sB))))) + +(defun package-menu--description-predicate (A B) + (let ((dA (aref (cadr A) 3)) + (dB (aref (cadr B) 3))) + (if (string= dA dB) + (package-menu--name-predicate A B) + (string< dA dB)))) + +(defun package-menu--name-predicate (A B) + (string< (symbol-name (caar A)) + (symbol-name (caar B)))) + +;;;###autoload +(defun list-packages (&optional no-fetch) + "Display a list of packages. +This first fetches the updated list of packages before +displaying, unless a prefix argument NO-FETCH is specified. +The list is displayed in a buffer named `*Packages*'." + (interactive "P") + (require 'finder-inf nil t) + ;; Initialize the package system if necessary. + (unless package--initialized + (package-initialize t)) + (let (old-archives new-packages) + (unless no-fetch + ;; Read the locally-cached archive-contents. + (package-read-all-archive-contents) + (setq old-archives package-archive-contents) + ;; Fetch the remote list of packages. + (package-refresh-contents) + ;; Find which packages are new. + (dolist (elt package-archive-contents) + (unless (assq (car elt) old-archives) + (push (car elt) new-packages)))) + + ;; Generate the Package Menu. + (let ((buf (get-buffer-create "*Packages*"))) + (with-current-buffer buf + (package-menu-mode) + (set (make-local-variable 'package-menu--new-package-list) + new-packages) + (package-menu--generate nil t)) + ;; The package menu buffer has keybindings. If the user types + ;; `M-x list-packages', that suggests it should become current. + (switch-to-buffer buf)) + + (let ((upgrades (package-menu--find-upgrades))) + (if upgrades + (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading." + (length upgrades) + (if (= (length upgrades) 1) "" "s") + (substitute-command-keys "\\[package-menu-mark-upgrades]") + (if (= (length upgrades) 1) "it" "them")))))) + +;;;###autoload +(defalias 'package-list-packages 'list-packages) + +;; Used in finder.el +(defun package-show-package-list (packages) + "Display PACKAGES in a *Packages* buffer. +This is similar to `list-packages', but it does not fetch the +updated list of packages, and it only displays packages with +names in PACKAGES (which should be a list of symbols)." + (require 'finder-inf nil t) + (let ((buf (get-buffer-create "*Packages*"))) + (with-current-buffer buf + (package-menu-mode) + (package-menu--generate nil packages)) + (switch-to-buffer buf))) + +(defun package-list-packages-no-fetch () + "Display a list of packages. +Does not fetch the updated list of packages before displaying. +The list is displayed in a buffer named `*Packages*'." + (interactive) + (list-packages t)) + +(provide 'package) + +;;; package.el ends here diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el new file mode 100644 index 00000000000..69834810d11 --- /dev/null +++ b/lisp/emacs-lisp/pcase.el @@ -0,0 +1,759 @@ +;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*- + +;; Copyright (C) 2010-2013 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; ML-style pattern matching. +;; The entry points are autoloaded. + +;; Todo: + +;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't +;; use x, because x is bound separately for the equality constraint +;; (as well as any pred/guard) and for the body, so uses at one place don't +;; count for the other. +;; - provide ways to extend the set of primitives, with some kind of +;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) +;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). +;; But better would be if we could define new ways to match by having the +;; extension provide its own `pcase--split-<foo>' thingy. +;; - along these lines, provide patterns to match CL structs. +;; - provide something like (setq VAR) so a var can be set rather than +;; let-bound. +;; - provide a way to fallthrough to subsequent cases (not sure what I meant by +;; this :-() +;; - try and be more clever to reduce the size of the decision tree, and +;; to reduce the number of leaves that need to be turned into function: +;; - first, do the tests shared by all remaining branches (it will have +;; to be performed anyway, so better do it first so it's shared). +;; - then choose the test that discriminates more (?). +;; - provide Agda's `with' (along with its `...' companion). +;; - implement (not UPAT). This might require a significant redesign. +;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to +;; generate a lex-style DFA to decide whether to run E1 or E2. + +;;; Code: + +(require 'macroexp) + +;; Macro-expansion of pcase is reasonably fast, so it's not a problem +;; when byte-compiling a file, but when interpreting the code, if the pcase +;; is in a loop, the repeated macro-expansion becomes terribly costly, so we +;; memoize previous macro expansions to try and avoid recomputing them +;; over and over again. +;; FIXME: Now that macroexpansion is also performed when loading an interpreted +;; file, this is not a real problem any more. +(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq)) +;; (defconst pcase--memoize-1 (make-hash-table :test 'eq)) +;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal)) + +(defconst pcase--dontcare-upats '(t _ pcase--dontcare)) + +(def-edebug-spec + pcase-UPAT + (&or symbolp + ("or" &rest pcase-UPAT) + ("and" &rest pcase-UPAT) + ("`" pcase-QPAT) + ("guard" form) + ("let" pcase-UPAT form) + ("pred" + &or lambda-expr + ;; Punt on macros/special forms. + (functionp &rest form) + sexp) + sexp)) + +(def-edebug-spec + pcase-QPAT + (&or ("," pcase-UPAT) + (pcase-QPAT . pcase-QPAT) + sexp)) + +;;;###autoload +(defmacro pcase (exp &rest cases) + "Perform ML-style pattern matching on EXP. +CASES is a list of elements of the form (UPATTERN CODE...). + +UPatterns can take the following forms: + _ matches anything. + SELFQUOTING matches itself. This includes keywords, numbers, and strings. + SYMBOL matches anything and binds it to SYMBOL. + (or UPAT...) matches if any of the patterns matches. + (and UPAT...) matches if all the patterns match. + `QPAT matches if the QPattern QPAT matches. + (pred PRED) matches if PRED applied to the object returns non-nil. + (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. + (let UPAT EXP) matches if EXP matches UPAT. +If a SYMBOL is used twice in the same pattern (i.e. the pattern is +\"non-linear\"), then the second occurrence is turned into an `eq'uality test. + +QPatterns can take the following forms: + (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. + ,UPAT matches if the UPattern UPAT matches. + STRING matches if the object is `equal' to STRING. + ATOM matches if the object is `eq' to ATOM. +QPatterns for vectors are not implemented yet. + +PRED can take the form + FUNCTION in which case it gets called with one argument. + (FUN ARG1 .. ARGN) in which case it gets called with an N+1'th argument + which is the value being matched. +A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION). +PRED patterns can refer to variables bound earlier in the pattern. +E.g. you can match pairs where the cdr is larger than the car with a pattern +like `(,a . ,(pred (< a))) or, with more checks: +`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" + (declare (indent 1) (debug (form &rest (pcase-UPAT body)))) + ;; We want to use a weak hash table as a cache, but the key will unavoidably + ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time + ;; we're called so it'll be immediately GC'd. So we use (car cases) as key + ;; which does come straight from the source code and should hence not be GC'd + ;; so easily. + (let ((data (gethash (car cases) pcase--memoize))) + ;; data = (EXP CASES . EXPANSION) + (if (and (equal exp (car data)) (equal cases (cadr data))) + ;; We have the right expansion. + (cddr data) + ;; (when (gethash (car cases) pcase--memoize-1) + ;; (message "pcase-memoize failed because of weak key!!")) + ;; (when (gethash (car cases) pcase--memoize-2) + ;; (message "pcase-memoize failed because of eq test on %S" + ;; (car cases))) + (when data + (message "pcase-memoize: equal first branch, yet different")) + (let ((expansion (pcase--expand exp cases))) + (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize) + ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1) + ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2) + expansion)))) + +(defun pcase--let* (bindings body) + (cond + ((null bindings) (macroexp-progn body)) + ((pcase--trivial-upat-p (caar bindings)) + (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body))) + (t + (let ((binding (pop bindings))) + (pcase--expand + (cadr binding) + `((,(car binding) ,(pcase--let* bindings body)) + ;; We can either signal an error here, or just use `pcase--dontcare' + ;; which generates more efficient code. In practice, if we use + ;; `pcase--dontcare' we will still often get an error and the few + ;; cases where we don't do not matter that much, so + ;; it's a better choice. + (pcase--dontcare nil))))))) + +;;;###autoload +(defmacro pcase-let* (bindings &rest body) + "Like `let*' but where you can use `pcase' patterns for bindings. +BODY should be an expression, and BINDINGS should be a list of bindings +of the form (UPAT EXP)." + (declare (indent 1) + (debug ((&rest (pcase-UPAT &optional form)) body))) + (let ((cached (gethash bindings pcase--memoize))) + ;; cached = (BODY . EXPANSION) + (if (equal (car cached) body) + (cdr cached) + (let ((expansion (pcase--let* bindings body))) + (puthash bindings (cons body expansion) pcase--memoize) + expansion)))) + +;;;###autoload +(defmacro pcase-let (bindings &rest body) + "Like `let' but where you can use `pcase' patterns for bindings. +BODY should be a list of expressions, and BINDINGS should be a list of bindings +of the form (UPAT EXP)." + (declare (indent 1) (debug pcase-let*)) + (if (null (cdr bindings)) + `(pcase-let* ,bindings ,@body) + (let ((matches '())) + (dolist (binding (prog1 bindings (setq bindings nil))) + (cond + ((memq (car binding) pcase--dontcare-upats) + (push (cons (make-symbol "_") (cdr binding)) bindings)) + ((pcase--trivial-upat-p (car binding)) (push binding bindings)) + (t + (let ((tmpvar (make-symbol (format "x%d" (length bindings))))) + (push (cons tmpvar (cdr binding)) bindings) + (push (list (car binding) tmpvar) matches))))) + `(let ,(nreverse bindings) (pcase-let* ,matches ,@body))))) + +(defmacro pcase-dolist (spec &rest body) + (declare (indent 1) (debug ((pcase-UPAT form) body))) + (if (pcase--trivial-upat-p (car spec)) + `(dolist ,spec ,@body) + (let ((tmpvar (make-symbol "x"))) + `(dolist (,tmpvar ,@(cdr spec)) + (pcase-let* ((,(car spec) ,tmpvar)) + ,@body))))) + + +(defun pcase--trivial-upat-p (upat) + (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) + +(defun pcase--expand (exp cases) + ;; (message "pid=%S (pcase--expand %S ...hash=%S)" + ;; (emacs-pid) exp (sxhash cases)) + (macroexp-let2 macroexp-copyable-p val exp + (let* ((defs ()) + (seen '()) + (codegen + (lambda (code vars) + (let ((prev (assq code seen))) + (if (not prev) + (let ((res (pcase-codegen code vars))) + (push (list code vars res) seen) + res) + ;; Since we use a tree-based pattern matching + ;; technique, the leaves (the places that contain the + ;; code to run once a pattern is matched) can get + ;; copied a very large number of times, so to avoid + ;; code explosion, we need to keep track of how many + ;; times we've used each leaf and move it + ;; to a separate function if that number is too high. + ;; + ;; We've already used this branch. So it is shared. + (let* ((code (car prev)) (cdrprev (cdr prev)) + (prevvars (car cdrprev)) (cddrprev (cdr cdrprev)) + (res (car cddrprev))) + (unless (symbolp res) + ;; This is the first repeat, so we have to move + ;; the branch to a separate function. + (let ((bsym + (make-symbol (format "pcase-%d" (length defs))))) + (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) + defs) + (setcar res 'funcall) + (setcdr res (cons bsym (mapcar #'cdr prevvars))) + (setcar (cddr prev) bsym) + (setq res bsym))) + (setq vars (copy-sequence vars)) + (let ((args (mapcar (lambda (pa) + (let ((v (assq (car pa) vars))) + (setq vars (delq v vars)) + (cdr v))) + prevvars))) + ;; If some of `vars' were not found in `prevvars', that's + ;; OK it just means those vars aren't present in all + ;; branches, so they can be used within the pattern + ;; (e.g. by a `guard/let/pred') but not in the branch. + ;; FIXME: But if some of `prevvars' are not in `vars' we + ;; should remove them from `prevvars'! + `(funcall ,res ,@args))))))) + (used-cases ()) + (main + (pcase--u + (mapcar (lambda (case) + `((match ,val . ,(car case)) + ,(lambda (vars) + (unless (memq case used-cases) + ;; Keep track of the cases that are used. + (push case used-cases)) + (funcall + (if (pcase--small-branch-p (cdr case)) + ;; Don't bother sharing multiple + ;; occurrences of this leaf since it's small. + #'pcase-codegen codegen) + (cdr case) + vars)))) + cases)))) + (dolist (case cases) + (unless (or (memq case used-cases) (eq (car case) 'pcase--dontcare)) + (message "Redundant pcase pattern: %S" (car case)))) + (macroexp-let* defs main)))) + +(defun pcase-codegen (code vars) + ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding + ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy + ;; codegen from later metamorphosing this let into a funcall. + `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) + ,@code)) + +(defun pcase--small-branch-p (code) + (and (= 1 (length code)) + (or (not (consp (car code))) + (let ((small t)) + (dolist (e (car code)) + (if (consp e) (setq small nil))) + small)))) + +;; Try to use `cond' rather than a sequence of `if's, so as to reduce +;; the depth of the generated tree. +(defun pcase--if (test then else) + (cond + ((eq else :pcase--dontcare) then) + ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen? + (t (macroexp-if test then else)))) + +(defun pcase--upat (qpattern) + (cond + ((eq (car-safe qpattern) '\,) (cadr qpattern)) + (t (list '\` qpattern)))) + +;; Note about MATCH: +;; When we have patterns like `(PAT1 . PAT2), after performing the `consp' +;; check, we want to turn all the similar patterns into ones of the form +;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction. +;; Earlier code hence used branches of the form (MATCHES . CODE) where +;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT). +;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is +;; no easy way to eliminate the `consp' check in such a representation. +;; So we replaced the MATCHES by the MATCH below which can be made up +;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can +;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into +;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)). +;; The downside is that we now have `or' and `and' both in MATCH and +;; in PAT, so there are different equivalent representations and we +;; need to handle them all. We do not try to systematically +;; canonicalize them to one form over another, but we do occasionally +;; turn one into the other. + +(defun pcase--u (branches) + "Expand matcher for rules BRANCHES. +Each BRANCH has the form (MATCH CODE . VARS) where +CODE is the code generator for that branch. +VARS is the set of vars already bound by earlier matches. +MATCH is the pattern that needs to be matched, of the form: + (match VAR . UPAT) + (and MATCH ...) + (or MATCH ...)" + (when (setq branches (delq nil branches)) + (let* ((carbranch (car branches)) + (match (car carbranch)) (cdarbranch (cdr carbranch)) + (code (car cdarbranch)) + (vars (cdr cdarbranch))) + (pcase--u1 (list match) code vars (cdr branches))))) + +(defun pcase--and (match matches) + (if matches `(and ,match ,@matches) match)) + +(defconst pcase-mutually-exclusive-predicates + '((symbolp . integerp) + (symbolp . numberp) + (symbolp . consp) + (symbolp . arrayp) + (symbolp . stringp) + (symbolp . byte-code-function-p) + (integerp . consp) + (integerp . arrayp) + (integerp . stringp) + (integerp . byte-code-function-p) + (numberp . consp) + (numberp . arrayp) + (numberp . stringp) + (numberp . byte-code-function-p) + (consp . arrayp) + (consp . stringp) + (consp . byte-code-function-p) + (arrayp . stringp) + (arrayp . byte-code-function-p) + (stringp . byte-code-function-p))) + +(defun pcase--split-match (sym splitter match) + (cond + ((eq (car match) 'match) + (if (not (eq sym (cadr match))) + (cons match match) + (let ((pat (cddr match))) + (cond + ;; Hoist `or' and `and' patterns to `or' and `and' matches. + ((memq (car-safe pat) '(or and)) + (pcase--split-match sym splitter + (cons (car pat) + (mapcar (lambda (alt) + `(match ,sym . ,alt)) + (cdr pat))))) + (t (let ((res (funcall splitter (cddr match)))) + (cons (or (car res) match) (or (cdr res) match)))))))) + ((memq (car match) '(or and)) + (let ((then-alts '()) + (else-alts '()) + (neutral-elem (if (eq 'or (car match)) + :pcase--fail :pcase--succeed)) + (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail))) + (dolist (alt (cdr match)) + (let ((split (pcase--split-match sym splitter alt))) + (unless (eq (car split) neutral-elem) + (push (car split) then-alts)) + (unless (eq (cdr split) neutral-elem) + (push (cdr split) else-alts)))) + (cons (cond ((memq zero-elem then-alts) zero-elem) + ((null then-alts) neutral-elem) + ((null (cdr then-alts)) (car then-alts)) + (t (cons (car match) (nreverse then-alts)))) + (cond ((memq zero-elem else-alts) zero-elem) + ((null else-alts) neutral-elem) + ((null (cdr else-alts)) (car else-alts)) + (t (cons (car match) (nreverse else-alts))))))) + (t (error "Uknown MATCH %s" match)))) + +(defun pcase--split-rest (sym splitter rest) + (let ((then-rest '()) + (else-rest '())) + (dolist (branch rest) + (let* ((match (car branch)) + (code&vars (cdr branch)) + (split + (pcase--split-match sym splitter match))) + (unless (eq (car split) :pcase--fail) + (push (cons (car split) code&vars) then-rest)) + (unless (eq (cdr split) :pcase--fail) + (push (cons (cdr split) code&vars) else-rest)))) + (cons (nreverse then-rest) (nreverse else-rest)))) + +(defun pcase--split-consp (syma symd pat) + (cond + ;; A QPattern for a cons, can only go the `then' side. + ((and (eq (car-safe pat) '\`) (consp (cadr pat))) + (let ((qpat (cadr pat))) + (cons `(and (match ,syma . ,(pcase--upat (car qpat))) + (match ,symd . ,(pcase--upat (cdr qpat)))) + :pcase--fail))) + ;; A QPattern but not for a cons, can only go to the `else' side. + ((eq (car-safe pat) '\`) (cons :pcase--fail nil)) + ((and (eq (car-safe pat) 'pred) + (or (member (cons 'consp (cadr pat)) + pcase-mutually-exclusive-predicates) + (member (cons (cadr pat) 'consp) + pcase-mutually-exclusive-predicates))) + (cons :pcase--fail nil)))) + +(defun pcase--split-equal (elem pat) + (cond + ;; The same match will give the same result. + ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) + (cons :pcase--succeed :pcase--fail)) + ;; A different match will fail if this one succeeds. + ((and (eq (car-safe pat) '\`) + ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) + ;; (consp (cadr pat))) + ) + (cons :pcase--fail nil)) + ((and (eq (car-safe pat) 'pred) + (symbolp (cadr pat)) + (get (cadr pat) 'side-effect-free) + (funcall (cadr pat) elem)) + (cons :pcase--succeed nil)))) + +(defun pcase--split-member (elems pat) + ;; Based on pcase--split-equal. + (cond + ;; The same match (or a match of membership in a superset) will + ;; give the same result, but we don't know how to check it. + ;; (??? + ;; (cons :pcase--succeed nil)) + ;; A match for one of the elements may succeed or fail. + ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) + nil) + ;; A different match will fail if this one succeeds. + ((and (eq (car-safe pat) '\`) + ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) + ;; (consp (cadr pat))) + ) + (cons :pcase--fail nil)) + ((and (eq (car-safe pat) 'pred) + (symbolp (cadr pat)) + (get (cadr pat) 'side-effect-free) + (let ((p (cadr pat)) (all t)) + (dolist (elem elems) + (unless (funcall p elem) (setq all nil))) + all)) + (cons :pcase--succeed nil)))) + +(defun pcase--split-pred (upat pat) + ;; FIXME: For predicates like (pred (> a)), two such predicates may + ;; actually refer to different variables `a'. + (let (test) + (cond + ((equal upat pat) (cons :pcase--succeed :pcase--fail)) + ((and (eq 'pred (car upat)) + (eq 'pred (car-safe pat)) + (or (member (cons (cadr upat) (cadr pat)) + pcase-mutually-exclusive-predicates) + (member (cons (cadr pat) (cadr upat)) + pcase-mutually-exclusive-predicates))) + (cons :pcase--fail nil)) + ((and (eq 'pred (car upat)) + (eq '\` (car-safe pat)) + (symbolp (cadr upat)) + (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) + (get (cadr upat) 'side-effect-free) + (ignore-errors + (setq test (list (funcall (cadr upat) (cadr pat)))))) + (if (car test) + (cons nil :pcase--fail) + (cons :pcase--fail nil)))))) + +(defun pcase--fgrep (vars sexp) + "Check which of the symbols VARS appear in SEXP." + (let ((res '())) + (while (consp sexp) + (dolist (var (pcase--fgrep vars (pop sexp))) + (unless (memq var res) (push var res)))) + (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) + res)) + +(defun pcase--self-quoting-p (upat) + (or (keywordp upat) (numberp upat) (stringp upat))) + +(defsubst pcase--mark-used (sym) + ;; Exceptionally, `sym' may be a constant expression rather than a symbol. + (if (symbolp sym) (put sym 'pcase-used t))) + +;; It's very tempting to use `pcase' below, tho obviously, it'd create +;; bootstrapping problems. +(defun pcase--u1 (matches code vars rest) + "Return code that runs CODE (with VARS) if MATCHES match. +Otherwise, it defers to REST which is a list of branches of the form +\(ELSE-MATCH ELSE-CODE . ELSE-VARS)." + ;; Depending on the order in which we choose to check each of the MATCHES, + ;; the resulting tree may be smaller or bigger. So in general, we'd want + ;; to be careful to chose the "optimal" order. But predicate + ;; patterns make this harder because they create dependencies + ;; between matches. So we don't bother trying to reorder anything. + (cond + ((null matches) (funcall code vars)) + ((eq :pcase--fail (car matches)) (pcase--u rest)) + ((eq :pcase--succeed (car matches)) + (pcase--u1 (cdr matches) code vars rest)) + ((eq 'and (caar matches)) + (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest)) + ((eq 'or (caar matches)) + (let* ((alts (cdar matches)) + (var (if (eq (caar alts) 'match) (cadr (car alts)))) + (simples '()) (others '())) + (when var + (dolist (alt alts) + (if (and (eq (car alt) 'match) (eq var (cadr alt)) + (let ((upat (cddr alt))) + (and (eq (car-safe upat) '\`) + (or (integerp (cadr upat)) (symbolp (cadr upat)) + (stringp (cadr upat)))))) + (push (cddr alt) simples) + (push alt others)))) + (cond + ((null alts) (error "Please avoid it") (pcase--u rest)) + ((> (length simples) 1) + ;; De-hoist the `or' MATCH into an `or' pattern that will be + ;; turned into a `memq' below. + (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) + code vars + (if (null others) rest + (cons (cons + (pcase--and (if (cdr others) + (cons 'or (nreverse others)) + (car others)) + (cdr matches)) + (cons code vars)) + rest)))) + (t + (pcase--u1 (cons (pop alts) (cdr matches)) code vars + (if (null alts) (progn (error "Please avoid it") rest) + (cons (cons + (pcase--and (if (cdr alts) + (cons 'or alts) (car alts)) + (cdr matches)) + (cons code vars)) + rest))))))) + ((eq 'match (caar matches)) + (let* ((popmatches (pop matches)) + (_op (car popmatches)) (cdrpopmatches (cdr popmatches)) + (sym (car cdrpopmatches)) + (upat (cdr cdrpopmatches))) + (cond + ((memq upat '(t _)) (pcase--u1 matches code vars rest)) + ((eq upat 'pcase--dontcare) :pcase--dontcare) + ((memq (car-safe upat) '(guard pred)) + (if (eq (car upat) 'pred) (pcase--mark-used sym)) + (let* ((splitrest + (pcase--split-rest + sym (lambda (pat) (pcase--split-pred upat pat)) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) + (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) + `(,(cadr upat) ,sym) + (let* ((exp (cadr upat)) + ;; `vs' is an upper bound on the vars we need. + (vs (pcase--fgrep (mapcar #'car vars) exp)) + (env (mapcar (lambda (var) + (list var (cdr (assq var vars)))) + vs)) + (call (if (eq 'guard (car upat)) + exp + (when (memq sym vs) + ;; `sym' is shadowed by `env'. + (let ((newsym (make-symbol "x"))) + (push (list newsym sym) env) + (setq sym newsym))) + (if (functionp exp) + `(funcall #',exp ,sym) + `(,@exp ,sym))))) + (if (null vs) + call + ;; Let's not replace `vars' in `exp' since it's + ;; too difficult to do it right, instead just + ;; let-bind `vars' around `exp'. + `(let* ,env ,call)))) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest)))) + ((pcase--self-quoting-p upat) + (pcase--mark-used sym) + (pcase--q1 sym upat matches code vars rest)) + ((symbolp upat) + (pcase--mark-used sym) + (if (not (assq upat vars)) + (pcase--u1 matches code (cons (cons upat sym) vars) rest) + ;; Non-linear pattern. Turn it into an `eq' test. + (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars))))) + matches) + code vars rest))) + ((eq (car-safe upat) 'let) + ;; A upat of the form (let VAR EXP). + ;; (pcase--u1 matches code + ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) + (macroexp-let2 + macroexp-copyable-p sym + (let* ((exp (nth 2 upat)) + (found (assq exp vars))) + (if found (cdr found) + (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) + (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) + vs))) + (if env (macroexp-let* env exp) exp)))) + (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) + code vars rest))) + ((eq (car-safe upat) '\`) + (pcase--mark-used sym) + (pcase--q1 sym (cadr upat) matches code vars rest)) + ((eq (car-safe upat) 'or) + (let ((all (> (length (cdr upat)) 1)) + (memq-fine t)) + (when all + (dolist (alt (cdr upat)) + (unless (or (pcase--self-quoting-p alt) + (and (eq (car-safe alt) '\`) + (or (symbolp (cadr alt)) (integerp (cadr alt)) + (setq memq-fine nil) + (stringp (cadr alt))))) + (setq all nil)))) + (if all + ;; Use memq for (or `a `b `c `d) rather than a big tree. + (let* ((elems (mapcar (lambda (x) (if (consp x) (cadr x) x)) + (cdr upat))) + (splitrest + (pcase--split-rest + sym (lambda (pat) (pcase--split-member elems pat)) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) + (pcase--mark-used sym) + (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest))) + (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars + (append (mapcar (lambda (upat) + `((and (match ,sym . ,upat) ,@matches) + ,code ,@vars)) + (cddr upat)) + rest))))) + ((eq (car-safe upat) 'and) + (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) + (cdr upat)) + matches) + code vars rest)) + ((eq (car-safe upat) 'not) + ;; FIXME: The implementation below is naive and results in + ;; inefficient code. + ;; To make it work right, we would need to turn pcase--u1's + ;; `code' and `vars' into a single argument of the same form as + ;; `rest'. We would also need to split this new `then-rest' argument + ;; for every test (currently we don't bother to do it since + ;; it's only useful for odd patterns like (and `(PAT1 . PAT2) + ;; `(PAT3 . PAT4)) which the programmer can easily rewrite + ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). + (pcase--u1 `((match ,sym . ,(cadr upat))) + ;; FIXME: This codegen is not careful to share its + ;; code if used several times: code blow up is likely. + (lambda (_vars) + ;; `vars' will likely contain bindings which are + ;; not always available in other paths to + ;; `rest', so there' no point trying to pass + ;; them down. + (pcase--u rest)) + vars + (list `((and . ,matches) ,code . ,vars)))) + (t (error "Unknown upattern `%s'" upat))))) + (t (error "Incorrect MATCH %s" (car matches))))) + +(defun pcase--q1 (sym qpat matches code vars rest) + "Return code that runs CODE if SYM matches QPAT and if MATCHES match. +Otherwise, it defers to REST which is a list of branches of the form +\(OTHER_MATCH OTHER-CODE . OTHER-VARS)." + (cond + ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN")) + ((floatp qpat) (error "Floating point patterns not supported")) + ((vectorp qpat) + ;; FIXME. + (error "Vector QPatterns not implemented yet")) + ((consp qpat) + (let* ((syma (make-symbol "xcar")) + (symd (make-symbol "xcdr")) + (splitrest (pcase--split-rest + sym + (lambda (pat) (pcase--split-consp syma symd pat)) + rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest)) + (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) + (match ,symd . ,(pcase--upat (cdr qpat))) + ,@matches) + code vars then-rest))) + (pcase--if + `(consp ,sym) + ;; We want to be careful to only add bindings that are used. + ;; The byte-compiler could do that for us, but it would have to pay + ;; attention to the `consp' test in order to figure out that car/cdr + ;; can't signal errors and our byte-compiler is not that clever. + ;; FIXME: Some of those let bindings occur too early (they are used in + ;; `then-body', but only within some sub-branch). + (macroexp-let* + `(,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) + ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) + then-body) + (pcase--u else-rest)))) + ((or (integerp qpat) (symbolp qpat) (stringp qpat)) + (let* ((splitrest (pcase--split-rest + sym (lambda (pat) (pcase--split-equal qpat pat)) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) + (pcase--if (cond + ((stringp qpat) `(equal ,sym ,qpat)) + ((null qpat) `(null ,sym)) + (t `(eq ,sym ',qpat))) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest)))) + (t (error "Unknown QPattern %s" qpat)))) + + +(provide 'pcase) +;;; pcase.el ends here diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index d1ab826d142..b7e553272f2 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -1,7 +1,6 @@ ;;; pp.el --- pretty printer for Emacs Lisp -;; Copyright (C) 1989, 1993, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1993, 2001-2013 Free Software Foundation, Inc. ;; Author: Randal Schwartz <merlyn@stonehenge.com> ;; Keywords: lisp @@ -42,17 +41,14 @@ "Return a string containing the pretty-printed representation of OBJECT. OBJECT can be any Lisp object. Quoting characters are used as needed to make output that `read' can handle, whenever this is possible." - (with-current-buffer (generate-new-buffer " pp-to-string") - (unwind-protect - (progn - (lisp-mode-variables nil) - (set-syntax-table emacs-lisp-mode-syntax-table) - (let ((print-escape-newlines pp-escape-newlines) - (print-quoted t)) - (prin1 object (current-buffer))) - (pp-buffer) - (buffer-string)) - (kill-buffer (current-buffer))))) + (with-temp-buffer + (lisp-mode-variables nil) + (set-syntax-table emacs-lisp-mode-syntax-table) + (let ((print-escape-newlines pp-escape-newlines) + (print-quoted t)) + (prin1 object (current-buffer))) + (pp-buffer) + (buffer-string))) ;;;###autoload (defun pp-buffer () @@ -61,9 +57,7 @@ to make output that `read' can handle, whenever this is possible." (while (not (eobp)) ;; (message "%06d" (- (point-max) (point))) (cond - ((condition-case err-var - (prog1 t (down-list 1)) - (error nil)) + ((ignore-errors (down-list 1) t) (save-excursion (backward-char 1) (skip-chars-backward "'`#^") @@ -72,10 +66,8 @@ to make output that `read' can handle, whenever this is possible." (point) (progn (skip-chars-backward " \t\n") (point))) (insert "\n")))) - ((condition-case err-var - (prog1 t (up-list 1)) - (error nil)) - (while (looking-at "\\s)") + ((ignore-errors (up-list 1) t) + (while (looking-at-p "\\s)") (forward-char 1)) (delete-region (point) @@ -118,7 +110,8 @@ after OUT-BUFFER-NAME." (progn (select-window window) (run-hooks 'temp-buffer-show-hook)) - (select-window old-selected) + (when (window-live-p old-selected) + (select-window old-selected)) (message "See buffer %s." out-buffer-name))) (message "%s" (buffer-substring (point-min) (point))) )))))) @@ -155,7 +148,7 @@ Also add the value to the front of the list in the variable `values'." (save-excursion (forward-sexp -1) ;; If first line is commented, ignore all leading comments: - (if (save-excursion (beginning-of-line) (looking-at "[ \t]*;")) + (if (save-excursion (beginning-of-line) (looking-at-p "[ \t]*;")) (progn (setq exp (buffer-substring (point) pt)) (while (string-match "\n[ \t]*;+" exp start) @@ -202,5 +195,4 @@ Ignores leading comment characters." (provide 'pp) ; so (require 'pp) works -;; arch-tag: b0f7c65b-02c7-42bb-9ee3-508a59b8fbb9 ;;; pp.el ends here diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 1647501f56e..9b73bea065f 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -1,7 +1,6 @@ -;;; re-builder.el --- building Regexps with visual feedback +;;; re-builder.el --- building Regexps with visual feedback -*- lexical-binding: t -*- -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1999-2013 Free Software Foundation, Inc. ;; Author: Detlev Zundel <dzu@gnu.org> ;; Keywords: matching, lisp, tools @@ -39,7 +38,7 @@ ;; the target buffer are marked automatically with colored overlays ;; (for non-color displays see below) giving you feedback over the ;; extents of the matched (sub) expressions. The (non-)validity is -;; shown only in the modeline without throwing the errors at you. If +;; shown only in the mode line without throwing the errors at you. If ;; you want to know the reason why RE Builder considers it as invalid ;; call `reb-force-update' ("\C-c\C-u") which should reveal the error. @@ -60,15 +59,13 @@ ;; even the auto updates go all the way. Forcing an update overrides ;; this limit allowing an easy way to see all matches. -;; Currently `re-builder' understands five different forms of input, -;; namely `read', `string', `rx', `sregex' and `lisp-re' syntax. Read +;; Currently `re-builder' understands three different forms of input, +;; namely `read', `string', and `rx' syntax. Read ;; syntax and string syntax are both delimited by `"'s and behave ;; according to their name. With the `string' syntax there's no need ;; to escape the backslashes and double quotes simplifying the editing ;; somewhat. The other three allow editing of symbolic regular -;; expressions supported by the packages of the same name. (`lisp-re' -;; is a package by me and its support may go away as it is nearly the -;; same as the `sregex' package in Emacs) +;; expressions supported by the packages of the same name. ;; Editing symbolic expressions is done through a major mode derived ;; from `emacs-lisp-mode' so you'll get all the good stuff like @@ -77,7 +74,7 @@ ;; When editing a symbolic regular expression, only the first ;; expression in the RE Builder buffer is considered, which helps ;; limiting the extent of the expression like the `"'s do for the text -;; modes. For the `sregex' syntax the function `sregex' is applied to +;; modes. For the `rx' syntax the function `rx-to-string' is applied to ;; the evaluated expression read. So you can use quoted arguments ;; with something like '("findme") or you can construct arguments to ;; your hearts delight with a valid ELisp expression. (The compiled @@ -128,12 +125,10 @@ (defcustom reb-re-syntax 'read "Syntax for the REs in the RE Builder. -Can either be `read', `string', `sregex', `lisp-re', `rx'." +Can either be `read', `string', or `rx'." :group 're-builder :type '(choice (const :tag "Read syntax" read) (const :tag "String syntax" string) - (const :tag "`sregex' syntax" sregex) - (const :tag "`lisp-re' syntax" lisp-re) (const :tag "`rx' syntax" rx))) (defcustom reb-auto-match-limit 200 @@ -280,22 +275,21 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (set (make-local-variable 'blink-matching-paren) nil) (reb-mode-common)) +(defvar reb-lisp-mode-map + (let ((map (make-sparse-keymap))) + ;; Use the same "\C-c" keymap as `reb-mode' and use font-locking from + ;; `emacs-lisp-mode' + (define-key map "\C-c" (lookup-key reb-mode-map "\C-c")) + map)) + (define-derived-mode reb-lisp-mode emacs-lisp-mode "RE Builder Lisp" "Major mode for interactively building symbolic Regular Expressions." - (cond ((eq reb-re-syntax 'lisp-re) ; Pull in packages - (require 'lisp-re)) ; as needed - ((eq reb-re-syntax 'sregex) ; sregex is not autoloaded - (require 'sregex)) ; right now.. - ((eq reb-re-syntax 'rx) ; rx-to-string is autoloaded - (require 'rx))) ; require rx anyway + ;; Pull in packages as needed + (cond ((memq reb-re-syntax '(sregex rx)) ; rx-to-string is autoloaded + (require 'rx))) ; require rx anyway (reb-mode-common)) -;; Use the same "\C-c" keymap as `reb-mode' and use font-locking from -;; `emacs-lisp-mode' -(define-key reb-lisp-mode-map "\C-c" - (lookup-key reb-mode-map "\C-c")) - (defvar reb-subexp-mode-map (let ((m (make-keymap))) (suppress-keymap m) @@ -331,7 +325,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (defsubst reb-lisp-syntax-p () "Return non-nil if RE Builder uses a Lisp syntax." - (memq reb-re-syntax '(lisp-re sregex rx))) + (memq reb-re-syntax '(sregex rx))) (defmacro reb-target-binding (symbol) "Return binding for SYMBOL in the RE Builder target buffer." @@ -357,9 +351,14 @@ Except for Lisp syntax this is the same as `reb-regexp'.") ;;;###autoload (defun re-builder () - "Construct a regexp interactively." - (interactive) + "Construct a regexp interactively. +This command makes the current buffer the \"target\" buffer of +the regexp builder. It displays a buffer named \"*RE-Builder*\" +in another window, initially containing an empty regexp. +As you edit the regexp in the \"*RE-Builder*\" buffer, the +matching parts of the target buffer will be highlighted." + (interactive) (if (and (string= (buffer-name) reb-buffer) (reb-mode-buffer-p)) (message "Already in the RE Builder") @@ -491,10 +490,10 @@ Optional argument SYNTAX must be specified if called non-interactively." (list (intern (completing-read "Select syntax: " (mapcar (lambda (el) (cons (symbol-name el) 1)) - '(read string lisp-re sregex rx)) + '(read string sregex rx)) nil t (symbol-name reb-re-syntax))))) - (if (memq syntax '(read string lisp-re sregex rx)) + (if (memq syntax '(read string sregex rx)) (let ((buffer (get-buffer reb-buffer))) (setq reb-re-syntax syntax) (when buffer @@ -512,7 +511,7 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (reb-update-regexp) (reb-update-overlays subexp)) -(defun reb-auto-update (beg end lenold &optional force) +(defun reb-auto-update (_beg _end _lenold &optional force) "Called from `after-update-functions' to update the display. BEG, END and LENOLD are passed in from the hook. An actual update is only done if the regexp has changed or if the @@ -618,12 +617,7 @@ optional fourth argument FORCE is non-nil." (defun reb-cook-regexp (re) "Return RE after processing it according to `reb-re-syntax'." - (cond ((eq reb-re-syntax 'lisp-re) - (when (fboundp 'lre-compile-string) - (lre-compile-string (eval (car (read-from-string re)))))) - ((eq reb-re-syntax 'sregex) - (apply 'sregex (eval (car (read-from-string re))))) - ((eq reb-re-syntax 'rx) + (cond ((memq reb-re-syntax '(sregex rx)) (rx-to-string (eval (car (read-from-string re))))) (t re))) @@ -720,12 +714,10 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (remove-hook 'after-change-functions 'reb-auto-update t) (remove-hook 'kill-buffer-hook 'reb-kill-buffer t) (when (reb-mode-buffer-p) - (reb-delete-overlays) - (funcall (or (default-value 'major-mode) 'fundamental-mode))))) + (reb-delete-overlays)))) ;; continue standard unloading nil) (provide 're-builder) -;; arch-tag: 5c5515ac-4085-4524-a421-033f44f032e7 ;;; re-builder.el ends here diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index 20d56a15724..de9966c0af0 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -1,7 +1,6 @@ ;;; regexp-opt.el --- generate efficient regexps to match strings -;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, -;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1994-2013 Free Software Foundation, Inc. ;; Author: Simon Marshall <simon@gnu.org> ;; Maintainer: FSF @@ -96,19 +95,24 @@ The returned regexp is typically more efficient than the equivalent regexp: (concat open (mapconcat 'regexp-quote STRINGS \"\\\\|\") close)) If PAREN is `words', then the resulting regexp is additionally surrounded -by \\=\\< and \\>." +by \\=\\< and \\>. +If PAREN is `symbols', then the resulting regexp is additionally surrounded +by \\=\\_< and \\_>." (save-match-data ;; Recurse on the sorted list. (let* ((max-lisp-eval-depth 10000) (max-specpdl-size 10000) (completion-ignore-case nil) (completion-regexp-list nil) - (words (eq paren 'words)) (open (cond ((stringp paren) paren) (paren "\\("))) (sorted-strings (delete-dups (sort (copy-sequence strings) 'string-lessp))) (re (regexp-opt-group sorted-strings (or open t) (not open)))) - (if words (concat "\\<" re "\\>") re)))) + (cond ((eq paren 'words) + (concat "\\<" re "\\>")) + ((eq paren 'symbols) + (concat "\\_<" re "\\_>")) + (t re))))) ;;;###autoload (defun regexp-opt-depth (regexp) @@ -120,7 +124,7 @@ This means the number of non-shy regexp grouping constructs (string-match regexp "") ;; Count the number of open parentheses in REGEXP. (let ((count 0) start last) - (while (string-match "\\\\(\\(\\?:\\)?" regexp start) + (while (string-match "\\\\(\\(\\?[0-9]*:\\)?" regexp start) (setq start (match-end 0)) ; Start of next search. (when (and (not (match-beginning 1)) (subregexp-context-p regexp (match-beginning 0) last)) @@ -132,14 +136,11 @@ This means the number of non-shy regexp grouping constructs ;;; Workhorse functions. -(eval-when-compile - (require 'cl)) - (defun regexp-opt-group (strings &optional paren lax) "Return a regexp to match a string in the sorted list STRINGS. If PAREN non-nil, output regexp parentheses around returned regexp. If LAX non-nil, don't output parentheses if it doesn't require them. -Merges keywords to avoid backtracking in Emacs' regexp matcher." +Merges keywords to avoid backtracking in Emacs's regexp matcher." ;; The basic idea is to find the shortest common prefix or suffix, remove it ;; and recurse. If there is no prefix, we divide the list into two so that ;; \(at least) one half will have at least a one-character common prefix. @@ -233,7 +234,8 @@ Merges keywords to avoid backtracking in Emacs' regexp matcher." (defun regexp-opt-charset (chars) - "Return a regexp to match a character in CHARS." + "Return a regexp to match a character in CHARS. +CHARS should be a list of characters." ;; The basic idea is to find character ranges. Also we take care in the ;; position of character set meta characters in the character set regexp. ;; @@ -244,15 +246,15 @@ Merges keywords to avoid backtracking in Emacs' regexp matcher." ;; ;; Make a character map but extract character set meta characters. (dolist (char chars) - (case char - (?\] - (setq bracket "]")) - (?^ - (setq caret "^")) - (?- - (setq dash "-")) - (otherwise - (aset charmap char t)))) + (cond + ((eq char ?\]) + (setq bracket "]")) + ((eq char ?^) + (setq caret "^")) + ((eq char ?-) + (setq dash "-")) + (t + (aset charmap char t)))) ;; ;; Make a character set from the map using ranges where applicable. (map-char-table @@ -264,14 +266,14 @@ Merges keywords to avoid backtracking in Emacs' regexp matcher." (setq charset (format "%s%c-%c" charset start end)) (while (>= end start) (setq charset (format "%s%c" charset start)) - (incf start))) + (setq start (1+ start)))) (setq start (car c) end (cdr c))) (if (= (1- c) end) (setq end c) (if (> end (+ start 2)) (setq charset (format "%s%c-%c" charset start end)) (while (>= end start) (setq charset (format "%s%c" charset start)) - (incf start))) + (setq start (1+ start)))) (setq start c end c))))) charmap) (when (>= end start) @@ -279,7 +281,7 @@ Merges keywords to avoid backtracking in Emacs' regexp matcher." (setq charset (format "%s%c-%c" charset start end)) (while (>= end start) (setq charset (format "%s%c" charset start)) - (incf start)))) + (setq start (1+ start))))) ;; ;; Make sure a caret is not first and a dash is first or last. (if (and (string-equal charset "") (string-equal bracket "")) @@ -288,5 +290,4 @@ Merges keywords to avoid backtracking in Emacs' regexp matcher." (provide 'regexp-opt) -;; arch-tag: 6c5a66f4-29af-4fd6-8c3b-4b554d5b4370 ;;; regexp-opt.el ends here diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index 44f82ddd6b8..9514ee62485 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -1,7 +1,6 @@ ;;; regi.el --- REGular expression Interpreting engine -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. ;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com> ;; Maintainer: bwarsaw@cen.com @@ -162,7 +161,7 @@ useful information: (progn (goto-char end) (regi-pos 'bonl)) (progn (goto-char start) (regi-pos 'bol))))) - ;; lets find the special tags and remove them from the working + ;; let's find the special tags and remove them from the working ;; frame. note that only the last special tag is used. (mapc (function @@ -254,5 +253,4 @@ useful information: (provide 'regi) -;; arch-tag: 804b4e45-4109-4f76-9a88-21887b881747 ;;; regi.el ends here diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index b2758ab8f1a..f2c4389e71f 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -1,7 +1,6 @@ ;;; ring.el --- handle rings of items -;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: extensions @@ -186,26 +185,31 @@ Raise error if ITEM is not in the RING." (unless curr-index (error "Item is not in the ring: `%s'" item)) (ring-ref ring (ring-minus1 curr-index (ring-length ring))))) +(defun ring-extend (ring x) + "Increase the size of RING by X." + (when (and (integerp x) (> x 0)) + (let* ((hd (car ring)) + (length (ring-length ring)) + (size (ring-size ring)) + (old-vec (cddr ring)) + (new-vec (make-vector (+ size x) nil))) + (setcdr ring (cons length new-vec)) + ;; If the ring is wrapped, the existing elements must be written + ;; out in the right order. + (dotimes (j length) + (aset new-vec j (aref old-vec (mod (+ hd j) size)))) + (setcar ring 0)))) + (defun ring-insert+extend (ring item &optional grow-p) "Like `ring-insert', but if GROW-P is non-nil, then enlarge ring. Insert onto ring RING the item ITEM, as the newest (last) item. If the ring is full, behavior depends on GROW-P: If GROW-P is non-nil, enlarge the ring to accommodate the new item. If GROW-P is nil, dump the oldest item to make room for the new." - (let* ((vec (cddr ring)) - (veclen (length vec)) - (hd (car ring)) - (ringlen (ring-length ring))) - (prog1 - (cond ((and grow-p (= ringlen veclen)) ; Full ring. Enlarge it. - (setq veclen (1+ veclen)) - (setcdr ring (cons (setq ringlen (1+ ringlen)) - (setq vec (vconcat vec (vector item))))) - (setcar ring hd)) - (t (aset vec (mod (+ hd ringlen) veclen) item))) - (if (= ringlen veclen) - (setcar ring (ring-plus1 hd veclen)) - (setcar (cdr ring) (1+ ringlen)))))) + (and grow-p + (= (ring-length ring) (ring-size ring)) + (ring-extend ring 1)) + (ring-insert ring item)) (defun ring-remove+insert+extend (ring item &optional grow-p) "`ring-remove' ITEM from RING, then `ring-insert+extend' it. @@ -236,5 +240,4 @@ If SEQ is already a ring, return it." (provide 'ring) -;; arch-tag: e707682b-ed69-47c9-b20f-cf2c68cc92d2 ;;; ring.el ends here diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index b660e8bdbcd..e578298106d 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1,7 +1,6 @@ ;;; rx.el --- sexp notation for regular expressions -;; Copyright (C) 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2001-2013 Free Software Foundation, Inc. ;; Author: Gerd Moellmann <gerd@gnu.org> ;; Maintainer: FSF @@ -36,9 +35,8 @@ ;; that the `repeat' form can't have multiple regexp args. ;; Now alternative forms are provided for a degree of compatibility -;; with Shivers' attempted definitive SRE notation -;; <URL:http://www.ai.mit.edu/~/shivers/sre.txt>. SRE forms not -;; catered for include: dsm, uncase, w/case, w/nocase, ,@<exp>, +;; with Olin Shivers' attempted definitive SRE notation. SRE forms +;; not catered for include: dsm, uncase, w/case, w/nocase, ,@<exp>, ;; ,<exp>, (word ...), word+, posix-string, and character class forms. ;; Some forms are inconsistent with SRE, either for historical reasons ;; or because of the implementation -- simple translation into Emacs @@ -109,7 +107,9 @@ ;;; Code: -(defconst rx-constituents +;; FIXME: support macros. + +(defvar rx-constituents ;Not `const' because some modes extend it. '((and . (rx-and 1 nil)) (seq . and) ; SRE (: . and) ; SRE @@ -120,19 +120,19 @@ (nonl . not-newline) ; SRE (anything . (rx-anything 0 nil)) (any . (rx-any 1 nil rx-check-any)) ; inconsistent with SRE + (any . ".") ; sregex (in . any) (char . any) ; sregex (not-char . (rx-not-char 1 nil rx-check-any)) ; sregex (not . (rx-not 1 1 rx-check-not)) - ;; Partially consistent with sregex, whose `repeat' is like our - ;; `**'. (`repeat' with optional max arg and multiple sexp forms - ;; is ambiguous.) - (repeat . (rx-repeat 2 3)) + (repeat . (rx-repeat 2 nil)) (= . (rx-= 2 nil)) ; SRE (>= . (rx->= 2 nil)) ; SRE (** . (rx-** 2 nil)) ; SRE (submatch . (rx-submatch 1 nil)) ; SRE - (group . submatch) + (group . submatch) ; sregex + (submatch-n . (rx-submatch-n 2 nil)) + (group-n . submatch-n) (zero-or-more . (rx-kleene 1 nil)) (one-or-more . (rx-kleene 1 nil)) (zero-or-one . (rx-kleene 1 nil)) @@ -175,6 +175,7 @@ (category . (rx-category 1 1 rx-check-category)) (eval . (rx-eval 1 1)) (regexp . (rx-regexp 1 1 stringp)) + (regex . regexp) ; sregex (digit . "[[:digit:]]") (numeric . digit) ; SRE (num . digit) ; SRE @@ -295,15 +296,27 @@ regular expression strings.") `zero-or-more', and `one-or-more'. Dynamically bound.") -(defun rx-info (op) +(defun rx-info (op head) "Return parsing/code generation info for OP. If OP is the space character ASCII 32, return info for the symbol `?'. If OP is the character `?', return info for the symbol `??'. -See also `rx-constituents'." +See also `rx-constituents'. +If HEAD is non-nil, then OP is the head of a sexp, otherwise it's +a standalone symbol." (cond ((eq op ? ) (setq op '\?)) ((eq op ??) (setq op '\??))) - (while (and (not (null op)) (symbolp op)) - (setq op (cdr (assq op rx-constituents)))) + (let (old-op) + (while (and (not (null op)) (symbolp op)) + (setq old-op op) + (setq op (cdr (assq op rx-constituents))) + (when (if head (stringp op) (consp op)) + ;; We found something but of the wrong kind. Let's look for an + ;; alternate definition for the other case. + (let ((new-op + (cdr (assq old-op (cdr (memq (assq old-op rx-constituents) + rx-constituents)))))) + (if (and new-op (not (if head (stringp new-op) (consp new-op)))) + (setq op new-op)))))) op) @@ -311,7 +324,7 @@ See also `rx-constituents'." "Check FORM according to its car's parsing info." (unless (listp form) (error "rx `%s' needs argument(s)" form)) - (let* ((rx (rx-info (car form))) + (let* ((rx (rx-info (car form) 'head)) (nargs (1- (length form))) (min-args (nth 1 rx)) (max-args (nth 2 rx)) @@ -381,7 +394,7 @@ FORM is of the form `(and FORM1 ...)'." (defun rx-anything (form) "Match any character." (if (consp form) - (error "rx `anythng' syntax error: %s" form)) + (error "rx `anything' syntax error: %s" form)) (rx-or (list 'or 'not-newline ?\n))) @@ -401,7 +414,7 @@ Only both edges of each range is checked." (setcdr m (1- char))))) ranges)) - + (defun rx-any-condense-range (args) "Condense by side effect ARGS as range for Rx `any'." (let (str @@ -564,7 +577,7 @@ ARG is optional." (condition-case nil (rx-form arg) (error "")))) - (eq arg 'word-boundary) + (eq arg 'word-boundary) (and (consp arg) (memq (car arg) '(not any in syntax category)))) (error "rx `not' syntax error: %s" arg)) @@ -643,14 +656,17 @@ If SKIP is non-nil, allow that number of items after the head, i.e. (defun rx-** (form) "Parse and produce code from FORM `(** N M ...)'." (rx-check form) - (setq form (cons 'repeat (cdr (rx-trans-forms form 2)))) - (rx-form form '*)) + (rx-form (cons 'repeat (cdr (rx-trans-forms form 2))) '*)) (defun rx-repeat (form) "Parse and produce code from FORM. -FORM is either `(repeat N FORM1)' or `(repeat N M FORM1)'." +FORM is either `(repeat N FORM1)' or `(repeat N M FORMS...)'." (rx-check form) + (if (> (length form) 4) + (setq form (rx-trans-forms form 2))) + (if (null (nth 2 form)) + (setq form (cons (nth 0 form) (cons (nth 1 form) (nthcdr 3 form))))) (cond ((= (length form) 3) (unless (and (integerp (nth 1 form)) (> (nth 1 form) 0)) @@ -677,6 +693,16 @@ FORM is either `(repeat N FORM1)' or `(repeat N M FORM1)'." (mapconcat (lambda (re) (rx-form re ':)) (cdr form) nil)) "\\)")) +(defun rx-submatch-n (form) + "Parse and produce code from FORM, which is `(submatch-n N ...)'." + (let ((n (nth 1 form))) + (concat "\\(?" (number-to-string n) ":" + (if (= 3 (length form)) + ;; Only one sub-form. + (rx-form (nth 2 form)) + ;; Several sub-forms implicitly concatenated. + (mapconcat (lambda (re) (rx-form re ':)) (cddr form) nil)) + "\\)"))) (defun rx-backref (form) "Parse and produce code from FORM, which is `(backref N)'." @@ -749,15 +775,18 @@ of all atomic regexps." "Parse and produce code from FORM, which is `(syntax SYMBOL)'." (rx-check form) (let* ((sym (cadr form)) - (syntax (assq sym rx-syntax))) + (syntax (cdr (assq sym rx-syntax)))) (unless syntax ;; Try sregex compatibility. - (let ((name (symbol-name sym))) - (if (= 1 (length name)) - (setq syntax (rassq (aref name 0) rx-syntax)))) + (cond + ((characterp sym) (setq syntax sym)) + ((symbolp sym) + (let ((name (symbol-name sym))) + (if (= 1 (length name)) + (setq syntax (aref name 0)))))) (unless syntax - (error "Unknown rx syntax `%s'" (cadr form)))) - (format "\\s%c" (cdr syntax)))) + (error "Unknown rx syntax `%s'" sym))) + (format "\\s%c" syntax))) (defun rx-check-category (form) @@ -804,27 +833,28 @@ If FORM is '(minimal-match FORM1)', non-greedy versions of `*', FORM is a regular expression in sexp form. RX-PARENT shows which type of expression calls and controls putting of shy groups around the result and some more in other functions." - (if (stringp form) - (rx-group-if (regexp-quote form) - (if (and (eq rx-parent '*) (< 1 (length form))) - rx-parent)) - (cond ((integerp form) - (regexp-quote (char-to-string form))) - ((symbolp form) - (let ((info (rx-info form))) - (cond ((stringp info) - info) - ((null info) - (error "Unknown rx form `%s'" form)) - (t - (funcall (nth 0 info) form))))) - ((consp form) - (let ((info (rx-info (car form)))) - (unless (consp info) - (error "Unknown rx form `%s'" (car form))) - (funcall (nth 0 info) form))) - (t - (error "rx syntax error at `%s'" form))))) + (cond + ((stringp form) + (rx-group-if (regexp-quote form) + (if (and (eq rx-parent '*) (< 1 (length form))) + rx-parent))) + ((integerp form) + (regexp-quote (char-to-string form))) + ((symbolp form) + (let ((info (rx-info form nil))) + (cond ((stringp info) + info) + ((null info) + (error "Unknown rx form `%s'" form)) + (t + (funcall (nth 0 info) form))))) + ((consp form) + (let ((info (rx-info (car form) 'head))) + (unless (consp info) + (error "Unknown rx form `%s'" (car form))) + (funcall (nth 0 info) form))) + (t + (error "rx syntax error at `%s'" form)))) ;;;###autoload @@ -1056,6 +1086,11 @@ CHAR like `and', but makes the match accessible with `match-end', `match-beginning', and `match-string'. +`(submatch-n N SEXP1 SEXP2 ...)' +`(group-n N SEXP1 SEXP2 ...)' + like `group', but make it an explicitly-numbered group with + group number N. + `(or SEXP1 SEXP2 ...)' `(| SEXP1 SEXP2 ...)' matches anything that matches SEXP1 or SEXP2, etc. If all @@ -1144,5 +1179,4 @@ enclosed in `(and ...)'. (provide 'rx) -;; arch-tag: 12d01a63-0008-42bb-ab8c-1c7d63be370b ;;; rx.el ends here diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index dad8e5bf596..b12fba17027 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -1,7 +1,6 @@ ;;; shadow.el --- locate Emacs Lisp file shadowings -;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2001-2013 Free Software Foundation, Inc. ;; Author: Terry Jones <terry@santafe.edu> ;; Keywords: lisp @@ -157,6 +156,40 @@ See the documentation for `list-load-path-shadows' for further information." (and (= (nth 7 (file-attributes f1)) (nth 7 (file-attributes f2))) (eq 0 (call-process "cmp" nil nil nil "-s" f1 f2)))))))) + +(defvar load-path-shadows-font-lock-keywords + ;; The idea is that shadows of files supplied with Emacs are more + ;; serious than various versions of external packages shadowing each + ;; other. + `((,(format "hides \\(%s.*\\)" + (file-name-directory + (or (locate-library "simple") + (file-name-as-directory + (expand-file-name "../lisp" data-directory))))) + . (1 font-lock-warning-face))) + "Keywords to highlight in `load-path-shadows-mode'.") + +(define-derived-mode load-path-shadows-mode fundamental-mode "LP-Shadows" + "Major mode for load-path shadows buffer." + (set (make-local-variable 'font-lock-defaults) + '((load-path-shadows-font-lock-keywords))) + (setq buffer-undo-list t + buffer-read-only t)) + +;; TODO use text-properties instead, a la dired. +(require 'button) +(define-button-type 'load-path-shadows-find-file + 'follow-link t +;; 'face 'default + 'action (lambda (button) + (let ((file (concat (button-get button 'shadow-file) ".el"))) + (or (file-exists-p file) + (setq file (concat file ".gz"))) + (if (file-readable-p file) + (pop-to-buffer (find-file-noselect file)) + (error "Cannot read file")))) + 'help-echo "mouse-2, RET: find this file") + ;;;###autoload (defun list-load-path-shadows (&optional stringp) @@ -240,14 +273,21 @@ function, `load-path-shadows-find'." ;; Create the *Shadows* buffer and display shadowings there. (let ((string (buffer-string))) (with-current-buffer (get-buffer-create "*Shadows*") - (fundamental-mode) ;run after-change-major-mode-hook. (display-buffer (current-buffer)) - (setq buffer-undo-list t - buffer-read-only nil) - (erase-buffer) - (insert string) - (insert msg "\n") - (setq buffer-read-only t))) + (load-path-shadows-mode) ; run after-change-major-mode-hook + (let ((inhibit-read-only t)) + (erase-buffer) + (insert string) + (insert msg "\n") + (while (re-search-backward "\\(^.*\\) hides \\(.*$\\)" + nil t) + (dotimes (i 2) + (make-button (match-beginning (1+ i)) + (match-end (1+ i)) + 'type 'load-path-shadows-find-file + 'shadow-file + (match-string (1+ i))))) + (goto-char (point-max))))) ;; We are non-interactive, print shadows via message. (unless (zerop n) (message "This site has duplicate Lisp libraries with the same name. @@ -265,5 +305,4 @@ version unless you know what you are doing.\n") (provide 'shadow) -;; arch-tag: 0480e8a7-62ed-4a12-a9f6-f44ded9b0830 ;;; shadow.el ends here diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index e537de6f031..eb3fa8f3b09 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1,6 +1,6 @@ -;;; smie.el --- Simple Minded Indentation Engine +;;; smie.el --- Simple Minded Indentation Engine -*- lexical-binding: t -*- -;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2010-2013 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: languages, lisp, internal, parsing, indentation @@ -56,7 +56,7 @@ ;; building the 2D precedence tables and then computing the precedence levels ;; from it) can be found in pages 187-194 of "Parsing techniques" by Dick Grune ;; and Ceriel Jacobs (BookBody.pdf available at -;; http://www.cs.vu.nl/~dick/PTAPG.html). +;; http://dickgrune.com/Books/PTAPG_1st_Edition/). ;; ;; OTOH we had to kill many chickens, read many coffee grounds, and practice ;; untold numbers of black magic spells, to come up with the indentation code. @@ -69,13 +69,23 @@ ;; (exp ("IF" exp "ELSE" exp "END") ("CASE" cases "END")) ;; (cases (cases "ELSE" insts) ...) ;; The IF-rule implies ELSE=END and the CASE-rule implies ELSE>END. -;; FIXME: we could try to resolve such conflicts automatically by changing -;; the way BNF rules such as the IF-rule is handled. I.e. rather than -;; IF=ELSE and ELSE=END, we could turn them into IF<ELSE and ELSE>END -;; and IF=END, +;; This can be resolved simply with: +;; (exp ("IF" expelseexp "END") ("CASE" cases "END")) +;; (expelseexp (exp) (exp "ELSE" exp)) +;; (cases (cases "ELSE" insts) ...) +;; - Another source of conflict is when a terminator/separator is used to +;; terminate elements at different levels, as in: +;; (decls ("VAR" vars) (decls "," decls)) +;; (vars (id) (vars "," vars)) +;; often these can be resolved by making the lexer distinguish the two +;; kinds of commas, e.g. based on the following token. ;; TODO & BUGS: ;; +;; - We could try to resolve conflicts such as the IFexpELSEexpEND -vs- +;; CASE(casesELSEexp)END automatically by changing the way BNF rules such as +;; the IF-rule is handled. I.e. rather than IF=ELSE and ELSE=END, we could +;; turn them into IF<ELSE and ELSE>END and IF=END. ;; - Using the structural information SMIE gives us, it should be possible to ;; implement a `smie-align' command that would automatically figure out what ;; there is to align and how to do it (something like: align the token of @@ -84,10 +94,34 @@ ;; - Maybe accept two juxtaposed non-terminals in the BNF under the condition ;; that the first always ends with a terminal, or that the second always ;; starts with a terminal. +;; - Permit EBNF-style notation. +;; - If the grammar has conflicts, the only way is to make the lexer return +;; different tokens for the different cases. This extra work performed by +;; the lexer can be costly and unnecessary: we perform this extra work every +;; time we find the conflicting token, regardless of whether or not the +;; difference between the various situations is relevant to the current +;; situation. E.g. we may try to determine whether a ";" is a ";-operator" +;; or a ";-separator" in a case where we're skipping over a "begin..end" pair +;; where the difference doesn't matter. For frequently occurring tokens and +;; rarely occurring conflicts, this can be a significant performance problem. +;; We could try and let the lexer return a "set of possible tokens +;; plus a refinement function" and then let parser call the refinement +;; function if needed. +;; - Make it possible to better specify the behavior in the face of +;; syntax errors. IOW provide some control over the choice of precedence +;; levels within the limits of the constraints. E.g. make it possible for +;; the grammar to specify that "begin..end" has lower precedence than +;; "Module..EndModule", so that if a "begin" is missing, scanning from the +;; "end" will stop at "Module" rather than going past it (and similarly, +;; scanning from "Module" should not stop at a spurious "end"). ;;; Code: -(eval-when-compile (require 'cl)) +;; FIXME: +;; - smie-indent-comment doesn't interact well with mis-indented lines (where +;; the indent rules don't do what the user wants). Not sure what to do. + +(eval-when-compile (require 'cl-lib)) (defgroup smie nil "Simple Minded Indentation Engine." @@ -110,7 +144,7 @@ ;; - a 2 dimensional precedence table (key word "prec2"), is a 2D ;; table recording the precedence relation (can be `<', `=', `>', or ;; nil) between each pair of tokens. -;; - a precedence-level table (key word "grammar"), which is a alist +;; - a precedence-level table (key word "grammar"), which is an alist ;; giving for each token its left and right precedence level (a ;; number or nil). This is used in `smie-grammar'. ;; The prec2 tables are only intermediate data structures: the source @@ -118,8 +152,10 @@ ;; turns them into a levels table, which is what's used by the rest of ;; the SMIE code. +(defvar smie-warning-count 0) + (defun smie-set-prec2tab (table x y val &optional override) - (assert (and x y)) + (cl-assert (and x y)) (let* ((key (cons x y)) (old (gethash key table))) (if (and old (not (eq old val))) @@ -129,7 +165,8 @@ ;; be able to distinguish the two cases so that overrides ;; don't hide real conflicts. (puthash key (gethash key override) table) - (display-warning 'smie (format "Conflict: %s %s/%s %s" x old val y))) + (display-warning 'smie (format "Conflict: %s %s/%s %s" x old val y)) + (cl-incf smie-warning-count)) (puthash key val table)))) (put 'smie-precs->prec2 'pure t) @@ -173,21 +210,54 @@ one of those elements share the same precedence level and associativity." prec2))) (put 'smie-bnf->prec2 'pure t) -(defun smie-bnf->prec2 (bnf &rest precs) +(defun smie-bnf->prec2 (bnf &rest resolvers) + "Convert the BNF grammar into a prec2 table. +BNF is a list of nonterminal definitions of the form: + \(NONTERM RHS1 RHS2 ...) +where each RHS is a (non-empty) list of terminals (aka tokens) or non-terminals. +Not all grammars are accepted: +- an RHS cannot be an empty list (this is not needed, since SMIE allows all + non-terminals to match the empty string anyway). +- an RHS cannot have 2 consecutive non-terminals: between each non-terminal + needs to be a terminal (aka token). This is a fundamental limitation of + the parsing technology used (operator precedence grammar). +Additionally, conflicts can occur: +- The returned prec2 table holds constraints between pairs of + token, and for any given pair only one constraint can be + present, either: T1 < T2, T1 = T2, or T1 > T2. +- A token can either be an `opener' (something similar to an open-paren), + a `closer' (like a close-paren), or `neither' of the two (e.g. an infix + operator, or an inner token like \"else\"). +Conflicts can be resolved via RESOLVERS, which is a list of elements that can +be either: +- a precs table (see `smie-precs->prec2') to resolve conflicting constraints, +- a constraint (T1 REL T2) where REL is one of = < or >." ;; FIXME: Add repetition operator like (repeat <separator> <elems>). ;; Maybe also add (or <elem1> <elem2>...) for things like ;; (exp (exp (or "+" "*" "=" ..) exp)). ;; Basically, make it EBNF (except for the specification of a separator in - ;; the repetition). - (let ((nts (mapcar 'car bnf)) ;Non-terminals - (first-ops-table ()) - (last-ops-table ()) - (first-nts-table ()) - (last-nts-table ()) - (prec2 (make-hash-table :test 'equal)) - (override (apply 'smie-merge-prec2s - (mapcar 'smie-precs->prec2 precs))) - again) + ;; the repetition, maybe). + (let* ((nts (mapcar 'car bnf)) ;Non-terminals. + (first-ops-table ()) + (last-ops-table ()) + (first-nts-table ()) + (last-nts-table ()) + (smie-warning-count 0) + (prec2 (make-hash-table :test 'equal)) + (override + (let ((precs ()) + (over (make-hash-table :test 'equal))) + (dolist (resolver resolvers) + (cond + ((and (= 3 (length resolver)) (memq (nth 1 resolver) '(= < >))) + (smie-set-prec2tab + over (nth 0 resolver) (nth 2 resolver) (nth 1 resolver))) + ((memq (caar resolver) '(left right assoc nonassoc)) + (push resolver precs)) + (t (error "Unknown resolver %S" resolver)))) + (apply #'smie-merge-prec2s over + (mapcar 'smie-precs->prec2 precs)))) + again) (dolist (rules bnf) (let ((nt (car rules)) (last-ops ()) @@ -198,8 +268,8 @@ one of those elements share the same precedence level and associativity." (unless (consp rhs) (signal 'wrong-type-argument `(consp ,rhs))) (if (not (member (car rhs) nts)) - (pushnew (car rhs) first-ops) - (pushnew (car rhs) first-nts) + (cl-pushnew (car rhs) first-ops) + (cl-pushnew (car rhs) first-nts) (when (consp (cdr rhs)) ;; If the first is not an OP we add the second (which ;; should be an OP if BNF is an "operator grammar"). @@ -209,15 +279,19 @@ one of those elements share the same precedence level and associativity." ;; the trouble, and it lets the writer of the BNF ;; be a bit more sloppy by skipping uninteresting base ;; cases which are terminals but not OPs. - (assert (not (member (cadr rhs) nts))) - (pushnew (cadr rhs) first-ops))) + (when (member (cadr rhs) nts) + (error "Adjacent non-terminals: %s %s" + (car rhs) (cadr rhs))) + (cl-pushnew (cadr rhs) first-ops))) (let ((shr (reverse rhs))) (if (not (member (car shr) nts)) - (pushnew (car shr) last-ops) - (pushnew (car shr) last-nts) + (cl-pushnew (car shr) last-ops) + (cl-pushnew (car shr) last-nts) (when (consp (cdr shr)) - (assert (not (member (cadr shr) nts))) - (pushnew (cadr shr) last-ops))))) + (when (member (cadr shr) nts) + (error "Adjacent non-terminals: %s %s" + (cadr shr) (car shr))) + (cl-pushnew (cadr shr) last-ops))))) (push (cons nt first-ops) first-ops-table) (push (cons nt last-ops) last-ops-table) (push (cons nt first-nts) first-nts-table) @@ -263,8 +337,11 @@ one of those elements share the same precedence level and associativity." (setq rhs (cdr rhs))))) ;; Keep track of which tokens are openers/closer, so they can get a nil ;; precedence in smie-prec2->grammar. - (puthash :smie-open/close-alist (smie-bnf-classify bnf) prec2) - (puthash :smie-closer-alist (smie-bnf-closer-alist bnf) prec2) + (puthash :smie-open/close-alist (smie-bnf--classify bnf) prec2) + (puthash :smie-closer-alist (smie-bnf--closer-alist bnf) prec2) + (if (> smie-warning-count 0) + (display-warning + 'smie (format "Total: %d warnings" smie-warning-count))) prec2)) ;; (defun smie-prec2-closer-alist (prec2 include-inners) @@ -319,7 +396,7 @@ one of those elements share the same precedence level and associativity." ;; openers) ;; alist))) -(defun smie-bnf-closer-alist (bnf &optional no-inners) +(defun smie-bnf--closer-alist (bnf &optional no-inners) ;; We can also build this closer-alist table from a prec2 table, ;; but it takes more work, and the order is unpredictable, which ;; is a problem for smie-close-block. @@ -339,45 +416,41 @@ from the table, e.g. the table will not include things like (\"if\" . \"else\"). (if no-inners (let ((last (car (last rhs)))) (unless (member last nts) - (pushnew (cons (car rhs) last) alist :test #'equal))) + (cl-pushnew (cons (car rhs) last) alist :test #'equal))) ;; Reverse so that the "real" closer gets there first, ;; which is important for smie-close-block. (dolist (term (reverse (cdr rhs))) (unless (member term nts) - (pushnew (cons (car rhs) term) alist :test #'equal))))))) + (cl-pushnew (cons (car rhs) term) alist :test #'equal))))))) (nreverse alist))) -(defun smie-bnf-classify (bnf) +(defun smie-bnf--set-class (table token class) + (let ((prev (gethash token table class))) + (puthash token + (cond + ((eq prev class) class) + ((eq prev t) t) ;Non-terminal. + (t (display-warning + 'smie + (format "token %s is both %s and %s" token class prev)) + 'neither)) + table))) + +(defun smie-bnf--classify (bnf) "Return a table classifying terminals. -Each terminal can either be an `opener', a `closer', or neither." +Each terminal can either be an `opener', a `closer', or `neither'." (let ((table (make-hash-table :test #'equal)) - (nts (mapcar #'car bnf)) (alist '())) (dolist (category bnf) - (puthash (car category) 'neither table) ;Remove non-terminals. + (puthash (car category) t table)) ;Mark non-terminals. + (dolist (category bnf) (dolist (rhs (cdr category)) (if (null (cdr rhs)) - (puthash (pop rhs) 'neither table) - (let ((first (pop rhs))) - (puthash first - (if (memq (gethash first table) '(nil opener)) - 'opener - (unless (member first nts) - (error "SMIE: token %s is both opener and non-opener" - first)) - 'neither) - table)) - (while (cdr rhs) - (puthash (pop rhs) 'neither table)) ;Remove internals. - (let ((last (pop rhs))) - (puthash last - (if (memq (gethash last table) '(nil closer)) - 'closer - (unless (member last nts) - (error "SMIE: token %s is both closer and non-closer" - last)) - 'neither) - table))))) + (smie-bnf--set-class table (pop rhs) 'neither) + (smie-bnf--set-class table (pop rhs) 'opener) + (while (cdr rhs) ;Remove internals. + (smie-bnf--set-class table (pop rhs) 'neither)) + (smie-bnf--set-class table (pop rhs) 'closer)))) (maphash (lambda (tok v) (when (memq v '(closer opener)) (push (cons tok v) alist))) @@ -410,7 +483,7 @@ CSTS is a list of pairs representing arcs in a graph." (push (concat "." (car elem)) res)) (if (eq (cddr elem) val) (push (concat (car elem) ".") res))) - (assert res) + (cl-assert res) res)) cycle))) (mapconcat @@ -425,9 +498,9 @@ CSTS is a list of pairs representing arcs in a graph." ;; (right (nth 1 (assoc (cdr k) grammar)))) ;; (when (and left right) ;; (cond -;; ((< left right) (assert (eq v '<))) -;; ((> left right) (assert (eq v '>))) -;; (t (assert (eq v '=)))))))) +;; ((< left right) (cl-assert (eq v '<))) +;; ((> left right) (cl-assert (eq v '>))) +;; (t (cl-assert (eq v '=)))))))) ;; prec2)) (put 'smie-prec2->grammar 'pure t) @@ -441,25 +514,28 @@ PREC2 is a table as returned by `smie-precs->prec2' or ;; final `table'. The value of each "variable" is kept in the `car'. (let ((table ()) (csts ()) - (eqs ()) - tmp x y) + (eqs ())) ;; From `prec2' we construct a list of constraints between ;; variables (aka "precedence levels"). These can be either ;; equality constraints (in `eqs') or `<' constraints (in `csts'). (maphash (lambda (k v) (when (consp k) - (if (setq tmp (assoc (car k) table)) - (setq x (cddr tmp)) - (setq x (cons nil nil)) - (push (cons (car k) (cons nil x)) table)) - (if (setq tmp (assoc (cdr k) table)) - (setq y (cdr tmp)) - (setq y (cons nil (cons nil nil))) - (push (cons (cdr k) y) table)) - (ecase v - (= (push (cons x y) eqs)) - (< (push (cons x y) csts)) - (> (push (cons y x) csts))))) + (let ((tmp (assoc (car k) table)) + x y) + (if tmp + (setq x (cddr tmp)) + (setq x (cons nil nil)) + (push (cons (car k) (cons nil x)) table)) + (if (setq tmp (assoc (cdr k) table)) + (setq y (cdr tmp)) + (setq y (cons nil (cons nil nil))) + (push (cons (cdr k) y) table)) + (pcase v + (`= (push (cons x y) eqs)) + (`< (push (cons x y) csts)) + (`> (push (cons y x) csts)) + (_ (error "SMIE error: prec2 has %S↦%S which ∉ {<,+,>}" + k v)))))) prec2) ;; First process the equality constraints. (let ((eqs eqs)) @@ -499,14 +575,14 @@ PREC2 is a table as returned by `smie-precs->prec2' or (unless (caar cst) (setcar (car cst) i) ;; (smie-check-grammar table prec2 'step1) - (incf i)) + (cl-incf i)) (setq csts (delq cst csts)))) (unless progress (error "Can't resolve the precedence cycle: %s" (smie-debug--describe-cycle table (smie-debug--prec2-cycle csts))))) - (incf i 10)) - ;; Propagate equalities back to their source. + (cl-incf i 10)) + ;; Propagate equality constraints back to their sources. (dolist (eq (nreverse eqs)) (when (null (cadr eq)) ;; There's an equality constraint, but we still haven't given @@ -516,8 +592,8 @@ PREC2 is a table as returned by `smie-precs->prec2' or ;; So set it here rather than below since doing it below ;; makes it more difficult to obey the equality constraints. (setcar (cdr eq) i) - (incf i)) - (assert (or (null (caar eq)) (eq (caar eq) (cadr eq)))) + (cl-incf i)) + (cl-assert (or (null (caar eq)) (eq (caar eq) (cadr eq)))) (setcar (car eq) (cadr eq)) ;; (smie-check-grammar table prec2 'step2) ) @@ -526,17 +602,17 @@ PREC2 is a table as returned by `smie-precs->prec2' or (dolist (x table) (unless (nth 1 x) (setf (nth 1 x) i) - (incf i)) ;See other (incf i) above. + (cl-incf i)) ;See other (cl-incf i) above. (unless (nth 2 x) (setf (nth 2 x) i) - (incf i)))) ;See other (incf i) above. + (cl-incf i)))) ;See other (cl-incf i) above. ;; Mark closers and openers. (dolist (x (gethash :smie-open/close-alist prec2)) (let* ((token (car x)) - (cons (case (cdr x) - (closer (cddr (assoc token table))) - (opener (cdr (assoc token table)))))) - (assert (numberp (car cons))) + (cons (pcase (cdr x) + (`closer (cddr (assoc token table))) + (`opener (cdr (assoc token table)))))) + (cl-assert (numberp (car cons))) (setf (car cons) (list (car cons))))) (let ((ca (gethash :smie-closer-alist prec2))) (when ca (push (cons :smie-closer-alist ca) table))) @@ -615,6 +691,7 @@ Possible return values: is too high. FORW-LEVEL is the forw-level of TOKEN, POS is its start position in the buffer. (t POS TOKEN): same thing when we bump on the wrong side of a paren. + Instead of t, the `car' can also be some other non-nil non-number value. (nil POS TOKEN): we skipped over a paren-like pair. nil: we skipped over an identifier, matched parentheses, ..." (catch 'return @@ -631,20 +708,19 @@ Possible return values: (when (zerop (length token)) (condition-case err (progn (goto-char pos) (funcall next-sexp 1) nil) - (scan-error (throw 'return - (list t (caddr err) - (buffer-substring-no-properties - (caddr err) - (+ (caddr err) - (if (< (point) (caddr err)) - -1 1))))))) + (scan-error + (let ((pos (nth 2 err))) + (throw 'return + (list t pos + (buffer-substring-no-properties + pos (+ pos (if (< (point) pos) -1 1)))))))) (if (eq pos (point)) ;; We did not move, so let's abort the loop. (throw 'return (list t (point)))))) ((not (numberp (funcall op-back toklevels))) ;; A token like a paren-close. - (assert (numberp ; Otherwise, why mention it in smie-grammar. - (funcall op-forw toklevels))) + (cl-assert (numberp ; Otherwise, why mention it in smie-grammar. + (funcall op-forw toklevels))) (push toklevels levels)) (t (while (and levels (< (funcall op-back toklevels) @@ -655,7 +731,8 @@ Possible return values: (if (and halfsexp (numberp (funcall op-forw toklevels))) (push toklevels levels) (throw 'return - (prog1 (list (or (car toklevels) t) (point) token) + (prog1 (list (or (funcall op-forw toklevels) t) + (point) token) (goto-char pos))))) (t (let ((lastlevels levels)) @@ -668,8 +745,22 @@ Possible return values: ;; Keep looking as long as we haven't matched the ;; topmost operator. (levels - (if (numberp (funcall op-forw toklevels)) - (push toklevels levels))) + (cond + ((numberp (funcall op-forw toklevels)) + (push toklevels levels)) + ;; FIXME: For some languages, we can express the grammar + ;; OK, but next-sexp doesn't stop where we'd want it to. + ;; E.g. in SML, we'd want to stop right in front of + ;; "local" if we're scanning (both forward and backward) + ;; from a "val/fun/..." at the same level. + ;; Same for Pascal/Modula2's "procedure" w.r.t + ;; "type/var/const". + ;; + ;; ((and (functionp (cadr (funcall op-forw toklevels))) + ;; (funcall (cadr (funcall op-forw toklevels)) + ;; levels)) + ;; (setq levels nil)) + )) ;; We matched the topmost operator. If the new operator ;; is the last in the corresponding BNF rule, we're done. ((not (numberp (funcall op-forw toklevels))) @@ -686,7 +777,8 @@ Possible return values: ((and lastlevels (smie--associative-p (car lastlevels))) (throw 'return - (prog1 (list (or (car toklevels) t) (point) token) + (prog1 (list (or (funcall op-forw toklevels) t) + (point) token) (goto-char pos)))) ;; - it's an associative operator within a larger construct ;; (e.g. an "elsif"), so we should just ignore it and keep @@ -706,6 +798,7 @@ Possible return values: is too high. LEFT-LEVEL is the left-level of TOKEN, POS is its start position in the buffer. (t POS TOKEN): same thing but for an open-paren or the beginning of buffer. + Instead of t, the `car' can also be some other non-nil non-number value. (nil POS TOKEN): we skipped over a paren-like pair. nil: we skipped over an identifier, matched parentheses, ..." (smie-next-sexp @@ -725,7 +818,8 @@ Possible return values: (RIGHT-LEVEL POS TOKEN): we couldn't skip TOKEN because its left-level is too high. RIGHT-LEVEL is the right-level of TOKEN, POS is its end position in the buffer. - (t POS TOKEN): same thing but for an open-paren or the beginning of buffer. + (t POS TOKEN): same thing but for a close-paren or the end of buffer. + Instead of t, the `car' can also be some other non-nil non-number value. (nil POS TOKEN): we skipped over a paren-like pair. nil: we skipped over an identifier, matched parentheses, ..." (smie-next-sexp @@ -735,7 +829,7 @@ Possible return values: (indirect-function 'smie-op-left) halfsexp)) -;;; Miscellanous commands using the precedence parser. +;;; Miscellaneous commands using the precedence parser. (defun smie-backward-sexp-command (&optional n) "Move backward through N logical elements." @@ -915,7 +1009,7 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'. ;; anything else than this trigger char, lest we'd blink ;; both when inserting the trigger char and when ;; inserting a subsequent trigger char like SPC. - (or (eq (point) pos) + (or (eq (char-before) last-command-event) (not (memq (char-before) smie-blink-matching-triggers))) (or smie-blink-matching-inners @@ -956,7 +1050,7 @@ function should return nil for arguments it does not expect. OFFSET can be: nil use the default indentation rule. -`(column . COLUMN) indent to column COLUMN. +\(column . COLUMN) indent to column COLUMN. NUMBER offset by NUMBER, relative to a base token which is the current token for :after and its parent for :before. @@ -987,6 +1081,16 @@ the beginning of a line." "Return non-nil if the current token is the first on the line." (save-excursion (skip-chars-backward " \t") (bolp))) +(defun smie-indent--bolp-1 () + ;; Like smie-indent--bolp but also returns non-nil if it's the first + ;; non-comment token. Maybe we should simply always use this? + "Return non-nil if the current token is the first on the line. +Comments are treated as spaces." + (let ((bol (line-beginning-position))) + (save-excursion + (forward-comment (- (point))) + (<= (point) bol)))) + ;; Dynamically scoped. (defvar smie--parent) (defvar smie--after) (defvar smie--token) @@ -998,7 +1102,10 @@ the beginning of a line." (unless (numberp (cadr (assoc tok smie-grammar))) (goto-char pos)) (setq smie--parent - (smie-backward-sexp 'halfsexp)))))) + (or (smie-backward-sexp 'halfsexp) + (let (res) + (while (null (setq res (smie-backward-sexp)))) + (list nil (point) (nth 2 res))))))))) (defun smie-rule-parent-p (&rest parents) "Return non-nil if the current token's parent is among PARENTS. @@ -1260,9 +1367,12 @@ should not be computed on the basis of the following token." ;; - middle-of-line: "trust current position". (cond ((smie-indent--rule :before token)) - ((smie-indent--bolp) ;I.e. non-virtual indent. + ((smie-indent--bolp-1) ;I.e. non-virtual indent. ;; For an open-paren-like thingy at BOL, always indent only ;; based on other rules (typically smie-indent-after-keyword). + ;; FIXME: we do the same if after a comment, since we may be trying + ;; to compute the indentation of this comment and we shouldn't indent + ;; based on the indentation of subsequent code. nil) (t ;; By default use point unless we're hanging. @@ -1363,6 +1473,12 @@ should not be computed on the basis of the following token." (save-excursion (forward-comment (point-max)) (skip-chars-forward " \t\r\n") + ;; FIXME: We assume here that smie-indent-calculate will compute the + ;; indentation of the next token based on text before the comment, but + ;; this is not guaranteed, so maybe we should let + ;; smie-indent-calculate return some info about which buffer position + ;; was used as the "indentation base" and check that this base is + ;; before `pos'. (smie-indent-calculate)))) (defun smie-indent-comment-continue () @@ -1403,6 +1519,10 @@ should not be computed on the basis of the following token." (and (nth 4 (syntax-ppss)) 'noindent)) +(defun smie-indent-inside-string () + (and (nth 3 (syntax-ppss)) + 'noindent)) + (defun smie-indent-after-keyword () ;; Indentation right after a special keyword. (save-excursion @@ -1476,8 +1596,9 @@ should not be computed on the basis of the following token." (defvar smie-indent-functions '(smie-indent-fixindent smie-indent-bob smie-indent-close - smie-indent-comment smie-indent-comment-continue smie-indent-comment-close - smie-indent-comment-inside smie-indent-keyword smie-indent-after-keyword + smie-indent-comment smie-indent-comment-continue smie-indent-comment-close + smie-indent-comment-inside smie-indent-inside-string + smie-indent-keyword smie-indent-after-keyword smie-indent-exps) "Functions to compute the indentation. Each function is called with no argument, shouldn't move point, and should @@ -1507,6 +1628,36 @@ to which that point should be aligned, if we were to reindent it.") (save-excursion (indent-line-to indent)) (indent-line-to indent))))) +(defun smie-auto-fill () + (let ((fc (current-fill-column))) + (while (and fc (> (current-column) fc)) + (cond + ((not (or (nth 8 (save-excursion + (syntax-ppss (line-beginning-position)))) + (nth 8 (syntax-ppss)))) + (save-excursion + (beginning-of-line) + (smie-indent-forward-token) + (let ((bsf (point)) + (gain 0) + curcol) + (while (<= (setq curcol (current-column)) fc) + ;; FIXME? `smie-indent-calculate' can (and often will) + ;; return a result that actually depends on the presence/absence + ;; of a newline, so the gain computed here may not be accurate, + ;; but in practice it seems to works well enough. + (let* ((newcol (smie-indent-calculate)) + (newgain (- curcol newcol))) + (when (> newgain gain) + (setq gain newgain) + (setq bsf (point)))) + (smie-indent-forward-token)) + (when (> gain 0) + (goto-char bsf) + (newline-and-indent))))) + (t (do-auto-fill)))))) + + (defun smie-setup (grammar rules-function &rest keywords) "Setup SMIE navigation and indentation. GRAMMAR is a grammar table generated by `smie-prec2->grammar'. @@ -1517,17 +1668,18 @@ KEYWORDS are additional arguments, which can use the following keywords: (set (make-local-variable 'smie-rules-function) rules-function) (set (make-local-variable 'smie-grammar) grammar) (set (make-local-variable 'indent-line-function) 'smie-indent-line) + (set (make-local-variable 'normal-auto-fill-function) 'smie-auto-fill) (set (make-local-variable 'forward-sexp-function) 'smie-forward-sexp-command) (while keywords (let ((k (pop keywords)) (v (pop keywords))) - (case k - (:forward-token + (pcase k + (`:forward-token (set (make-local-variable 'smie-forward-token-function) v)) - (:backward-token + (`:backward-token (set (make-local-variable 'smie-backward-token-function) v)) - (t (message "smie-setup: ignoring unknown keyword %s" k))))) + (_ (message "smie-setup: ignoring unknown keyword %s" k))))) (let ((ca (cdr (assq :smie-closer-alist grammar)))) (when ca (set (make-local-variable 'smie-closer-alist) ca) @@ -1547,8 +1699,9 @@ KEYWORDS are additional arguments, which can use the following keywords: (while (setq closer (pop closers)) (unless (and closers ;; FIXME: this eliminates prefixes of other - ;; closers, but we should probably elimnate - ;; prefixes of other keywords as well. + ;; closers, but we should probably + ;; eliminate prefixes of other keywords + ;; as well. (string-prefix-p closer (car closers))) (push (aref closer (1- (length closer))) triggers))) (delete-dups triggers))))))) diff --git a/lisp/emacs-lisp/sregex.el b/lisp/emacs-lisp/sregex.el deleted file mode 100644 index e5ff50d39d2..00000000000 --- a/lisp/emacs-lisp/sregex.el +++ /dev/null @@ -1,608 +0,0 @@ -;;; sregex.el --- symbolic regular expressions - -;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. - -;; Author: Bob Glickstein <bobg+sregex@zanshin.com> -;; Maintainer: Bob Glickstein <bobg+sregex@zanshin.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 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This package allows you to write regular expressions using a -;; totally new, Lisp-like syntax. - -;; A "symbolic regular expression" (sregex for short) is a Lisp form -;; that, when evaluated, produces the string form of the specified -;; regular expression. Here's a simple example: - -;; (sregexq (or "Bob" "Robert")) => "Bob\\|Robert" - -;; As you can see, an sregex is specified by placing one or more -;; special clauses in a call to `sregexq'. The clause in this case is -;; the `or' of two strings (not to be confused with the Lisp function -;; `or'). The list of allowable clauses appears below. - -;; With sregex, it is never necessary to "escape" magic characters -;; that are meant to be taken literally; that happens automatically. -;; For example: - -;; (sregexq "M*A*S*H") => "M\\*A\\*S\\*H" - -;; It is also unnecessary to "group" parts of the expression together -;; to overcome operator precedence; that also happens automatically. -;; For example: - -;; (sregexq (opt (or "Bob" "Robert"))) => "\\(?:Bob\\|Robert\\)?" - -;; It *is* possible to group parts of the expression in order to refer -;; to them with numbered backreferences: - -;; (sregexq (group (or "Go" "Run")) -;; ", Spot, " -;; (backref 1)) => "\\(Go\\|Run\\), Spot, \\1" - -;; `sregexq' is a macro. Each time it is used, it constructs a simple -;; Lisp expression that then invokes a moderately complex engine to -;; interpret the sregex and render the string form. Because of this, -;; I don't recommend sprinkling calls to `sregexq' throughout your -;; code, the way one normally does with string regexes (which are -;; cheap to evaluate). Instead, it's wiser to precompute the regexes -;; you need wherever possible instead of repeatedly constructing the -;; same ones over and over. Example: - -;; (let ((field-regex (sregexq (opt "resent-") -;; (or "to" "cc" "bcc")))) -;; ... -;; (while ... -;; ... -;; (re-search-forward field-regex ...) -;; ...)) - -;; The arguments to `sregexq' are automatically quoted, but the -;; flipside of this is that it is not straightforward to include -;; computed (i.e., non-constant) values in `sregexq' expressions. So -;; `sregex' is a function that is like `sregexq' but which does not -;; automatically quote its values. Literal sregex clauses must be -;; explicitly quoted like so: - -;; (sregex '(or "Bob" "Robert")) => "Bob\\|Robert" - -;; but computed clauses can be included easily, allowing for the reuse -;; of common clauses: - -;; (let ((dotstar '(0+ any)) -;; (whitespace '(1+ (syntax ?-))) -;; (digits '(1+ (char (?0 . ?9))))) -;; (sregex 'bol dotstar ":" whitespace digits)) => "^.*:\\s-+[0-9]+" - -;; To use this package in a Lisp program, simply (require 'sregex). - -;; Here are the clauses allowed in an `sregex' or `sregexq' -;; expression: - -;; - a string -;; This stands for the literal string. If it contains -;; metacharacters, they will be escaped in the resulting regex -;; (using `regexp-quote'). - -;; - the symbol `any' -;; This stands for ".", a regex matching any character except -;; newline. - -;; - the symbol `bol' -;; Stands for "^", matching the empty string at the beginning of a line - -;; - the symbol `eol' -;; Stands for "$", matching the empty string at the end of a line - -;; - (group CLAUSE ...) -;; Groups the given CLAUSEs using "\\(" and "\\)". - -;; - (sequence CLAUSE ...) - -;; Groups the given CLAUSEs; may or may not use "\\(?:" and "\\)". -;; Clauses grouped by `sequence' do not count for purposes of -;; numbering backreferences. Use `sequence' in situations like -;; this: - -;; (sregexq (or "dog" "cat" -;; (sequence (opt "sea ") "monkey"))) -;; => "dog\\|cat\\|\\(?:sea \\)?monkey" - -;; where a single `or' alternate needs to contain multiple -;; subclauses. - -;; - (backref N) -;; Matches the same string previously matched by the Nth "group" in -;; the same sregex. N is a positive integer. - -;; - (or CLAUSE ...) -;; Matches any one of the CLAUSEs by separating them with "\\|". - -;; - (0+ CLAUSE ...) -;; Concatenates the given CLAUSEs and matches zero or more -;; occurrences by appending "*". - -;; - (1+ CLAUSE ...) -;; Concatenates the given CLAUSEs and matches one or more -;; occurrences by appending "+". - -;; - (opt CLAUSE ...) -;; Concatenates the given CLAUSEs and matches zero or one occurrence -;; by appending "?". - -;; - (repeat MIN MAX CLAUSE ...) -;; Concatenates the given CLAUSEs and constructs a regex matching at -;; least MIN occurrences and at most MAX occurrences. MIN must be a -;; non-negative integer. MAX must be a non-negative integer greater -;; than or equal to MIN; or MAX can be nil to mean "infinity." - -;; - (char CHAR-CLAUSE ...) -;; Creates a "character class" matching one character from the given -;; set. See below for how to construct a CHAR-CLAUSE. - -;; - (not-char CHAR-CLAUSE ...) -;; Creates a "character class" matching any one character not in the -;; given set. See below for how to construct a CHAR-CLAUSE. - -;; - the symbol `bot' -;; Stands for "\\`", matching the empty string at the beginning of -;; text (beginning of a string or of a buffer). - -;; - the symbol `eot' -;; Stands for "\\'", matching the empty string at the end of text. - -;; - the symbol `point' -;; Stands for "\\=", matching the empty string at point. - -;; - the symbol `word-boundary' -;; Stands for "\\b", matching the empty string at the beginning or -;; end of a word. - -;; - the symbol `not-word-boundary' -;; Stands for "\\B", matching the empty string not at the beginning -;; or end of a word. - -;; - the symbol `bow' -;; Stands for "\\<", matching the empty string at the beginning of a -;; word. - -;; - the symbol `eow' -;; Stands for "\\>", matching the empty string at the end of a word. - -;; - the symbol `wordchar' -;; Stands for the regex "\\w", matching a word-constituent character -;; (as determined by the current syntax table) - -;; - the symbol `not-wordchar' -;; Stands for the regex "\\W", matching a non-word-constituent -;; character. - -;; - (syntax CODE) -;; Stands for the regex "\\sCODE", where CODE is a syntax table code -;; (a single character). Matches any character with the requested -;; syntax. - -;; - (not-syntax CODE) -;; Stands for the regex "\\SCODE", where CODE is a syntax table code -;; (a single character). Matches any character without the -;; requested syntax. - -;; - (regex REGEX) -;; This is a "trapdoor" for including ordinary regular expression -;; strings in the result. Some regular expressions are clearer when -;; written the old way: "[a-z]" vs. (sregexq (char (?a . ?z))), for -;; instance. However, see the note under "Bugs," below. - -;; Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...) -;; has one of the following forms: - -;; - a character -;; Adds that character to the set. - -;; - a string -;; Adds all the characters in the string to the set. - -;; - A pair (MIN . MAX) -;; Where MIN and MAX are characters, adds the range of characters -;; from MIN through MAX to the set. - -;;; To do: - -;; An earlier version of this package could optionally translate the -;; symbolic regex into other languages' syntaxes, e.g. Perl. For -;; instance, with Perl syntax selected, (sregexq (or "ab" "cd")) would -;; yield "ab|cd" instead of "ab\\|cd". It might be useful to restore -;; such a facility. - -;; - handle multibyte chars in sregex--char-aux -;; - add support for character classes ([:blank:], ...) -;; - add support for non-greedy operators *? and +? -;; - bug: (sregexq (opt (opt ?a))) returns "a??" which is a non-greedy "a?" - -;;; Bugs: - -;;; Code: - -(eval-when-compile (require 'cl)) - -;; Compatibility code for when we didn't have shy-groups -(defvar sregex--current-sregex nil) -(defun sregex-info () nil) -(defmacro sregex-save-match-data (&rest forms) (cons 'save-match-data forms)) -(defun sregex-replace-match (r &optional f l str subexp x) - (replace-match r f l str subexp)) -(defun sregex-match-string (c &optional i x) (match-string c i)) -(defun sregex-match-string-no-properties (count &optional in-string sregex) - (match-string-no-properties count in-string)) -(defun sregex-match-beginning (count &optional sregex) (match-beginning count)) -(defun sregex-match-end (count &optional sregex) (match-end count)) -(defun sregex-match-data (&optional sregex) (match-data)) -(defun sregex-backref-num (n &optional sregex) n) - - -(defun sregex (&rest exps) - "Symbolic regular expression interpreter. -This is exactly like `sregexq' (q.v.) except that it evaluates all its -arguments, so literal sregex clauses must be quoted. For example: - - (sregex '(or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" - -An argument-evaluating sregex interpreter lets you reuse sregex -subexpressions: - - (let ((dotstar '(0+ any)) - (whitespace '(1+ (syntax ?-))) - (digits '(1+ (char (?0 . ?9))))) - (sregex 'bol dotstar \":\" whitespace digits)) => \"^.*:\\\\s-+[0-9]+\"" - (sregex--sequence exps nil)) - -(defmacro sregexq (&rest exps) - "Symbolic regular expression interpreter. -This macro allows you to specify a regular expression (regexp) in -symbolic form, and converts it into the string form required by Emacs's -regex functions such as `re-search-forward' and `looking-at'. Here is -a simple example: - - (sregexq (or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" - -As you can see, an sregex is specified by placing one or more special -clauses in a call to `sregexq'. The clause in this case is the `or' -of two strings (not to be confused with the Lisp function `or'). The -list of allowable clauses appears below. - -With `sregex', it is never necessary to \"escape\" magic characters -that are meant to be taken literally; that happens automatically. -For example: - - (sregexq \"M*A*S*H\") => \"M\\\\*A\\\\*S\\\\*H\" - -It is also unnecessary to \"group\" parts of the expression together -to overcome operator precedence; that also happens automatically. -For example: - - (sregexq (opt (or \"Bob\" \"Robert\"))) => \"\\\\(Bob\\\\|Robert\\\\)?\" - -It *is* possible to group parts of the expression in order to refer -to them with numbered backreferences: - - (sregexq (group (or \"Go\" \"Run\")) - \", Spot, \" - (backref 1)) => \"\\\\(Go\\\\|Run\\\\), Spot, \\\\1\" - -If `sregexq' needs to introduce its own grouping parentheses, it will -automatically renumber your backreferences: - - (sregexq (opt \"resent-\") - (group (or \"to\" \"cc\" \"bcc\")) - \": \" - (backref 1)) => \"\\\\(resent-\\\\)?\\\\(to\\\\|cc\\\\|bcc\\\\): \\\\2\" - -`sregexq' is a macro. Each time it is used, it constructs a simple -Lisp expression that then invokes a moderately complex engine to -interpret the sregex and render the string form. Because of this, I -don't recommend sprinkling calls to `sregexq' throughout your code, -the way one normally does with string regexes (which are cheap to -evaluate). Instead, it's wiser to precompute the regexes you need -wherever possible instead of repeatedly constructing the same ones -over and over. Example: - - (let ((field-regex (sregexq (opt \"resent-\") - (or \"to\" \"cc\" \"bcc\")))) - ... - (while ... - ... - (re-search-forward field-regex ...) - ...)) - -The arguments to `sregexq' are automatically quoted, but the -flipside of this is that it is not straightforward to include -computed (i.e., non-constant) values in `sregexq' expressions. So -`sregex' is a function that is like `sregexq' but which does not -automatically quote its values. Literal sregex clauses must be -explicitly quoted like so: - - (sregex '(or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" - -but computed clauses can be included easily, allowing for the reuse -of common clauses: - - (let ((dotstar '(0+ any)) - (whitespace '(1+ (syntax ?-))) - (digits '(1+ (char (?0 . ?9))))) - (sregex 'bol dotstar \":\" whitespace digits)) => \"^.*:\\\\s-+[0-9]+\" - -Here are the clauses allowed in an `sregex' or `sregexq' expression: - -- a string - This stands for the literal string. If it contains - metacharacters, they will be escaped in the resulting regex - (using `regexp-quote'). - -- the symbol `any' - This stands for \".\", a regex matching any character except - newline. - -- the symbol `bol' - Stands for \"^\", matching the empty string at the beginning of a line - -- the symbol `eol' - Stands for \"$\", matching the empty string at the end of a line - -- (group CLAUSE ...) - Groups the given CLAUSEs using \"\\\\(\" and \"\\\\)\". - -- (sequence CLAUSE ...) - - Groups the given CLAUSEs; may or may not use \"\\\\(\" and \"\\\\)\". - Clauses grouped by `sequence' do not count for purposes of - numbering backreferences. Use `sequence' in situations like - this: - - (sregexq (or \"dog\" \"cat\" - (sequence (opt \"sea \") \"monkey\"))) - => \"dog\\\\|cat\\\\|\\\\(?:sea \\\\)?monkey\" - - where a single `or' alternate needs to contain multiple - subclauses. - -- (backref N) - Matches the same string previously matched by the Nth \"group\" in - the same sregex. N is a positive integer. - -- (or CLAUSE ...) - Matches any one of the CLAUSEs by separating them with \"\\\\|\". - -- (0+ CLAUSE ...) - Concatenates the given CLAUSEs and matches zero or more - occurrences by appending \"*\". - -- (1+ CLAUSE ...) - Concatenates the given CLAUSEs and matches one or more - occurrences by appending \"+\". - -- (opt CLAUSE ...) - Concatenates the given CLAUSEs and matches zero or one occurrence - by appending \"?\". - -- (repeat MIN MAX CLAUSE ...) - Concatenates the given CLAUSEs and constructs a regex matching at - least MIN occurrences and at most MAX occurrences. MIN must be a - non-negative integer. MAX must be a non-negative integer greater - than or equal to MIN; or MAX can be nil to mean \"infinity.\" - -- (char CHAR-CLAUSE ...) - Creates a \"character class\" matching one character from the given - set. See below for how to construct a CHAR-CLAUSE. - -- (not-char CHAR-CLAUSE ...) - Creates a \"character class\" matching any one character not in the - given set. See below for how to construct a CHAR-CLAUSE. - -- the symbol `bot' - Stands for \"\\\\`\", matching the empty string at the beginning of - text (beginning of a string or of a buffer). - -- the symbol `eot' - Stands for \"\\\\'\", matching the empty string at the end of text. - -- the symbol `point' - Stands for \"\\\\=\\=\", matching the empty string at point. - -- the symbol `word-boundary' - Stands for \"\\\\b\", matching the empty string at the beginning or - end of a word. - -- the symbol `not-word-boundary' - Stands for \"\\\\B\", matching the empty string not at the beginning - or end of a word. - -- the symbol `bow' - Stands for \"\\\\=\\<\", matching the empty string at the beginning of a - word. - -- the symbol `eow' - Stands for \"\\\\=\\>\", matching the empty string at the end of a word. - -- the symbol `wordchar' - Stands for the regex \"\\\\w\", matching a word-constituent character - (as determined by the current syntax table) - -- the symbol `not-wordchar' - Stands for the regex \"\\\\W\", matching a non-word-constituent - character. - -- (syntax CODE) - Stands for the regex \"\\\\sCODE\", where CODE is a syntax table code - (a single character). Matches any character with the requested - syntax. - -- (not-syntax CODE) - Stands for the regex \"\\\\SCODE\", where CODE is a syntax table code - (a single character). Matches any character without the - requested syntax. - -- (regex REGEX) - This is a \"trapdoor\" for including ordinary regular expression - strings in the result. Some regular expressions are clearer when - written the old way: \"[a-z]\" vs. (sregexq (char (?a . ?z))), for - instance. - -Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...) -has one of the following forms: - -- a character - Adds that character to the set. - -- a string - Adds all the characters in the string to the set. - -- A pair (MIN . MAX) - Where MIN and MAX are characters, adds the range of characters - from MIN through MAX to the set." - `(apply 'sregex ',exps)) - -(defun sregex--engine (exp combine) - (cond - ((stringp exp) - (if (and combine - (eq combine 'suffix) - (/= (length exp) 1)) - (concat "\\(?:" (regexp-quote exp) "\\)") - (regexp-quote exp))) - ((symbolp exp) - (ecase exp - (any ".") - (bol "^") - (eol "$") - (wordchar "\\w") - (not-wordchar "\\W") - (bot "\\`") - (eot "\\'") - (point "\\=") - (word-boundary "\\b") - (not-word-boundary "\\B") - (bow "\\<") - (eow "\\>"))) - ((consp exp) - (funcall (intern (concat "sregex--" - (symbol-name (car exp)))) - (cdr exp) - combine)) - (t (error "Invalid expression: %s" exp)))) - -(defun sregex--sequence (exps combine) - (if (= (length exps) 1) (sregex--engine (car exps) combine) - (let ((re (mapconcat - (lambda (e) (sregex--engine e 'concat)) - exps ""))) - (if (eq combine 'suffix) - (concat "\\(?:" re "\\)") - re)))) - -(defun sregex--or (exps combine) - (if (= (length exps) 1) (sregex--engine (car exps) combine) - (let ((re (mapconcat - (lambda (e) (sregex--engine e 'or)) - exps "\\|"))) - (if (not (eq combine 'or)) - (concat "\\(?:" re "\\)") - re)))) - -(defun sregex--group (exps combine) (concat "\\(" (sregex--sequence exps nil) "\\)")) - -(defun sregex--backref (exps combine) (concat "\\" (int-to-string (car exps)))) -(defun sregex--opt (exps combine) (concat (sregex--sequence exps 'suffix) "?")) -(defun sregex--0+ (exps combine) (concat (sregex--sequence exps 'suffix) "*")) -(defun sregex--1+ (exps combine) (concat (sregex--sequence exps 'suffix) "+")) - -(defun sregex--char (exps combine) (sregex--char-aux nil exps)) -(defun sregex--not-char (exps combine) (sregex--char-aux t exps)) - -(defun sregex--syntax (exps combine) (format "\\s%c" (car exps))) -(defun sregex--not-syntax (exps combine) (format "\\S%c" (car exps))) - -(defun sregex--regex (exps combine) - (if combine (concat "\\(?:" (car exps) "\\)") (car exps))) - -(defun sregex--repeat (exps combine) - (let* ((min (or (pop exps) 0)) - (minstr (number-to-string min)) - (max (pop exps))) - (concat (sregex--sequence exps 'suffix) - (concat "\\{" minstr "," - (when max (number-to-string max)) "\\}")))) - -(defun sregex--char-range (start end) - (let ((startc (char-to-string start)) - (endc (char-to-string end))) - (cond - ((> end (+ start 2)) (concat startc "-" endc)) - ((> end (+ start 1)) (concat startc (char-to-string (1+ start)) endc)) - ((> end start) (concat startc endc)) - (t startc)))) - -(defun sregex--char-aux (complement args) - ;; regex-opt does the same, we should join effort. - (let ((chars (make-bool-vector 256 nil))) ; Yeah, right! - (dolist (arg args) - (cond ((integerp arg) (aset chars arg t)) - ((stringp arg) (mapc (lambda (c) (aset chars c t)) arg)) - ((consp arg) - (let ((start (car arg)) - (end (cdr arg))) - (when (> start end) - (let ((tmp start)) (setq start end) (setq end tmp))) - ;; now start <= end - (let ((i start)) - (while (<= i end) - (aset chars i t) - (setq i (1+ i)))))))) - ;; now chars is a map of the characters in the class - (let ((caret (aref chars ?^)) - (dash (aref chars ?-)) - (class (if (aref chars ?\]) "]" ""))) - (aset chars ?^ nil) - (aset chars ?- nil) - (aset chars ?\] nil) - - (let (start end) - (dotimes (i 256) - (if (aref chars i) - (progn - (unless start (setq start i)) - (setq end i) - (aset chars i nil)) - (when start - (setq class (concat class (sregex--char-range start end))) - (setq start nil)))) - (if start - (setq class (concat class (sregex--char-range start end))))) - - (if (> (length class) 0) - (setq class (concat class (if caret "^") (if dash "-"))) - (setq class (concat class (if dash "-") (if caret "^")))) - (if (and (not complement) (= (length class) 1)) - (regexp-quote class) - (concat "[" (if complement "^") class "]"))))) - -(provide 'sregex) - -;; arch-tag: 460c1f5a-eb6e-42ec-a451-ffac78bdf492 -;;; sregex.el ends here diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 6fcb0b6efac..bf2c8308bb5 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -1,7 +1,6 @@ -;;; syntax.el --- helper functions to find syntactic context +;;; syntax.el --- helper functions to find syntactic context -*- lexical-binding: t -*- -;; Copyright (C) 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2000-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal @@ -34,7 +33,6 @@ ;; - do something about the case where the syntax-table is changed. ;; This typically happens with tex-mode and its `$' operator. -;; - move font-lock-syntactic-keywords in here. Then again, maybe not. ;; - new functions `syntax-state', ... to replace uses of parse-partial-state ;; with something higher-level (similar to syntax-ppss-context). ;; - interaction with mmm-mode. @@ -43,10 +41,290 @@ ;; Note: PPSS stands for `parse-partial-sexp state' -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar font-lock-beginning-of-syntax-function) +;;; Applying syntax-table properties where needed. + +(defvar syntax-propertize-function nil + ;; Rather than a -functions hook, this is a -function because it's easier + ;; to do a single scan than several scans: with multiple scans, one cannot + ;; assume that the text before point has been propertized, so syntax-ppss + ;; gives unreliable results (and stores them in its cache to boot, so we'd + ;; have to flush that cache between each function, and we couldn't use + ;; syntax-ppss-flush-cache since that would not only flush the cache but also + ;; reset syntax-propertize--done which should not be done in this case). + "Mode-specific function to apply `syntax-table' text properties. +The value of this variable is a function to be called by Font +Lock mode, prior to performing syntactic fontification on a +stretch of text. It is given two arguments, START and END: the +start and end of the text to be fontified. Major modes can +specify a custom function to apply `syntax-table' properties to +override the default syntax table in special cases. + +The specified function may call `syntax-ppss' on any position +before END, but it should not call `syntax-ppss-flush-cache', +which means that it should not call `syntax-ppss' on some +position and later modify the buffer on some earlier position.") + +(defvar syntax-propertize-chunk-size 500) + +(defvar syntax-propertize-extend-region-functions + '(syntax-propertize-wholelines) + "Special hook run just before proceeding to propertize a region. +This is used to allow major modes to help `syntax-propertize' find safe buffer +positions as beginning and end of the propertized region. Its most common use +is to solve the problem of /identification/ of multiline elements by providing +a function that tries to find such elements and move the boundaries such that +they do not fall in the middle of one. +Each function is called with two arguments (START and END) and it should return +either a cons (NEW-START . NEW-END) or nil if no adjustment should be made. +These functions are run in turn repeatedly until they all return nil. +Put first the functions more likely to cause a change and cheaper to compute.") +;; Mark it as a special hook which doesn't use any global setting +;; (i.e. doesn't obey the element t in the buffer-local value). +(make-variable-buffer-local 'syntax-propertize-extend-region-functions) + +(defun syntax-propertize-wholelines (start end) + (goto-char start) + (cons (line-beginning-position) + (progn (goto-char end) + (if (bolp) (point) (line-beginning-position 2))))) + +(defun syntax-propertize-multiline (beg end) + "Let `syntax-propertize' pay attention to the syntax-multiline property." + (when (and (> beg (point-min)) + (get-text-property (1- beg) 'syntax-multiline)) + (setq beg (or (previous-single-property-change beg 'syntax-multiline) + (point-min)))) + ;; + (when (get-text-property end 'font-lock-multiline) + (setq end (or (text-property-any end (point-max) + 'syntax-multiline nil) + (point-max)))) + (cons beg end)) + +(defvar syntax-propertize--done -1 + "Position up to which syntax-table properties have been set.") +(make-variable-buffer-local 'syntax-propertize--done) + +(defun syntax-propertize--shift-groups (re n) + (replace-regexp-in-string + "\\\\(\\?\\([0-9]+\\):" + (lambda (s) + (replace-match + (number-to-string (+ n (string-to-number (match-string 1 s)))) + t t s 1)) + re t t)) + +(defmacro syntax-propertize-precompile-rules (&rest rules) + "Return a precompiled form of RULES to pass to `syntax-propertize-rules'. +The arg RULES can be of the same form as in `syntax-propertize-rules'. +The return value is an object that can be passed as a rule to +`syntax-propertize-rules'. +I.e. this is useful only when you want to share rules among several +`syntax-propertize-function's." + (declare (debug syntax-propertize-rules)) + ;; Precompile? Yeah, right! + ;; Seriously, tho, this is a macro for 2 reasons: + ;; - we could indeed do some pre-compilation at some point in the future, + ;; e.g. fi/when we switch to a DFA-based implementation of + ;; syntax-propertize-rules. + ;; - this lets Edebug properly annotate the expressions inside RULES. + `',rules) + +(defmacro syntax-propertize-rules (&rest rules) + "Make a function that applies RULES for use in `syntax-propertize-function'. +The function will scan the buffer, applying the rules where they match. +The buffer is scanned a single time, like \"lex\" would, rather than once +per rule. + +Each RULE can be a symbol, in which case that symbol's value should be, +at macro-expansion time, a precompiled set of rules, as returned +by `syntax-propertize-precompile-rules'. + +Otherwise, RULE should have the form (REGEXP HIGHLIGHT1 ... HIGHLIGHTn), where +REGEXP is an expression (evaluated at time of macro-expansion) that returns +a regexp, and where HIGHLIGHTs have the form (NUMBER SYNTAX) which means to +apply the property SYNTAX to the chars matched by the subgroup NUMBER +of the regular expression, if NUMBER did match. +SYNTAX is an expression that returns a value to apply as `syntax-table' +property. Some expressions are handled specially: +- if SYNTAX is a string, then it is converted with `string-to-syntax'; +- if SYNTAX has the form (prog1 EXP . EXPS) then the value returned by EXP + will be applied to the buffer before running EXPS and if EXP is a string it + is also converted with `string-to-syntax'. +The SYNTAX expression is responsible to save the `match-data' if needed +for subsequent HIGHLIGHTs. +Also SYNTAX is free to move point, in which case RULES may not be applied to +some parts of the text or may be applied several times to other parts. + +Note: back-references in REGEXPs do not work." + (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step. + (form &rest + (numberp + [&or stringp ;FIXME: Use &wrap + ("prog1" [&or stringp def-form] def-body) + def-form]))))) + (let ((newrules nil)) + (while rules + (if (symbolp (car rules)) + (setq rules (append (symbol-value (pop rules)) rules)) + (push (pop rules) newrules))) + (setq rules (nreverse newrules))) + (let* ((offset 0) + (branches '()) + ;; We'd like to use a real DFA-based lexer, usually, but since Emacs + ;; doesn't have one yet, we fallback on building one large regexp + ;; and use groups to determine which branch of the regexp matched. + (re + (mapconcat + (lambda (rule) + (let* ((orig-re (eval (car rule))) + (re orig-re)) + (when (and (assq 0 rule) (cdr rules)) + ;; If there's more than 1 rule, and the rule want to apply + ;; highlight to match 0, create an extra group to be able to + ;; tell when *this* match 0 has succeeded. + (cl-incf offset) + (setq re (concat "\\(" re "\\)"))) + (setq re (syntax-propertize--shift-groups re offset)) + (let ((code '()) + (condition + (cond + ((assq 0 rule) (if (zerop offset) t + `(match-beginning ,offset))) + ((null (cddr rule)) + `(match-beginning ,(+ offset (car (cadr rule))))) + (t + `(or ,@(mapcar + (lambda (case) + `(match-beginning ,(+ offset (car case)))) + (cdr rule)))))) + (nocode t) + (offset offset)) + ;; If some of the subgroup rules include Elisp code, then we + ;; need to set the match-data so it's consistent with what the + ;; code expects. If not, then we can simply use shifted + ;; offset in our own code. + (unless (zerop offset) + (dolist (case (cdr rule)) + (unless (stringp (cadr case)) + (setq nocode nil))) + (unless nocode + (push `(let ((md (match-data 'ints))) + ;; Keep match 0 as is, but shift everything else. + (setcdr (cdr md) (nthcdr ,(* (1+ offset) 2) md)) + (set-match-data md)) + code) + (setq offset 0))) + ;; Now construct the code for each subgroup rules. + (dolist (case (cdr rule)) + (cl-assert (null (cddr case))) + (let* ((gn (+ offset (car case))) + (action (nth 1 case)) + (thiscode + (cond + ((stringp action) + `((put-text-property + (match-beginning ,gn) (match-end ,gn) + 'syntax-table + ',(string-to-syntax action)))) + ((eq (car-safe action) 'ignore) + (cdr action)) + ((eq (car-safe action) 'prog1) + (if (stringp (nth 1 action)) + `((put-text-property + (match-beginning ,gn) (match-end ,gn) + 'syntax-table + ',(string-to-syntax (nth 1 action))) + ,@(nthcdr 2 action)) + `((let ((mb (match-beginning ,gn)) + (me (match-end ,gn)) + (syntax ,(nth 1 action))) + (if syntax + (put-text-property + mb me 'syntax-table syntax)) + ,@(nthcdr 2 action))))) + (t + `((let ((mb (match-beginning ,gn)) + (me (match-end ,gn)) + (syntax ,action)) + (if syntax + (put-text-property + mb me 'syntax-table syntax)))))))) + + (if (or (not (cddr rule)) (zerop gn)) + (setq code (nconc (nreverse thiscode) code)) + (push `(if (match-beginning ,gn) + ;; Try and generate clean code with no + ;; extraneous progn. + ,(if (null (cdr thiscode)) + (car thiscode) + `(progn ,@thiscode))) + code)))) + (push (cons condition (nreverse code)) + branches)) + (cl-incf offset (regexp-opt-depth orig-re)) + re)) + rules + "\\|"))) + `(lambda (start end) + (goto-char start) + (while (and (< (point) end) + (re-search-forward ,re end t)) + (cond ,@(nreverse branches)))))) + +(defun syntax-propertize-via-font-lock (keywords) + "Propertize for syntax in START..END using font-lock syntax. +KEYWORDS obeys the format used in `font-lock-syntactic-keywords'. +The return value is a function suitable for `syntax-propertize-function'." + (lambda (start end) + (with-no-warnings + (let ((font-lock-syntactic-keywords keywords)) + (font-lock-fontify-syntactic-keywords-region start end) + ;; In case it was eval'd/compiled. + (setq keywords font-lock-syntactic-keywords))))) + +(defun syntax-propertize (pos) + "Ensure that syntax-table properties are set until POS." + (when (and syntax-propertize-function + (< syntax-propertize--done pos)) + ;; (message "Needs to syntax-propertize from %s to %s" + ;; syntax-propertize--done pos) + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (save-excursion + (with-silent-modifications + (let* ((start (max syntax-propertize--done (point-min))) + (end (max pos + (min (point-max) + (+ start syntax-propertize-chunk-size)))) + (funs syntax-propertize-extend-region-functions)) + (while funs + (let ((new (funcall (pop funs) start end))) + (if (or (null new) + (and (>= (car new) start) (<= (cdr new) end))) + nil + (setq start (car new)) + (setq end (cdr new)) + ;; If there's been a change, we should go through the + ;; list again since this new position may + ;; warrant a different answer from one of the funs we've + ;; already seen. + (unless (eq funs + (cdr syntax-propertize-extend-region-functions)) + (setq funs syntax-propertize-extend-region-functions))))) + ;; Move the limit before calling the function, so the function + ;; can use syntax-ppss. + (setq syntax-propertize--done end) + ;; (message "syntax-propertizing from %s to %s" start end) + (remove-text-properties start end + '(syntax-table nil syntax-multiline nil)) + (funcall syntax-propertize-function start end)))))) + +;;; Incrementally compute and memoize parser state. + (defsubst syntax-ppss-depth (ppss) (nth 0 ppss)) @@ -92,6 +370,8 @@ point (where the PPSS is equivalent to nil).") (defalias 'syntax-ppss-after-change-function 'syntax-ppss-flush-cache) (defun syntax-ppss-flush-cache (beg &rest ignored) "Flush the cache of `syntax-ppss' starting at position BEG." + ;; Set syntax-propertize to refontify anything past beg. + (setq syntax-propertize--done (min beg syntax-propertize--done)) ;; Flush invalid cache entries. (while (and syntax-ppss-cache (> (caar syntax-ppss-cache) beg)) (setq syntax-ppss-cache (cdr syntax-ppss-cache))) @@ -123,11 +403,13 @@ point (where the PPSS is equivalent to nil).") (defun syntax-ppss (&optional pos) "Parse-Partial-Sexp State at POS, defaulting to point. -The returned value is the same as `parse-partial-sexp' except that -the 2nd and 6th values of the returned state cannot be relied upon. +The returned value is the same as that of `parse-partial-sexp' +run from point-min to POS except that values at positions 2 and 6 +in the returned list (counting from 0) cannot be relied upon. Point is at POS when this function returns." ;; Default values. (unless pos (setq pos (point))) + (syntax-propertize pos) ;; (let ((old-ppss (cdr syntax-ppss-last)) (old-pos (car syntax-ppss-last)) @@ -142,8 +424,8 @@ Point is at POS when this function returns." (* 2 (/ (cdr (aref syntax-ppss-stats 5)) (1+ (car (aref syntax-ppss-stats 5))))))) (progn - (incf (car (aref syntax-ppss-stats 0))) - (incf (cdr (aref syntax-ppss-stats 0)) (- pos old-pos)) + (cl-incf (car (aref syntax-ppss-stats 0))) + (cl-incf (cdr (aref syntax-ppss-stats 0)) (- pos old-pos)) (parse-partial-sexp old-pos pos nil nil old-ppss)) (cond @@ -159,8 +441,8 @@ Point is at POS when this function returns." (setq pt-min (or (syntax-ppss-toplevel-pos old-ppss) (nth 2 old-ppss))) (<= pt-min pos) (< (- pos pt-min) syntax-ppss-max-span)) - (incf (car (aref syntax-ppss-stats 1))) - (incf (cdr (aref syntax-ppss-stats 1)) (- pos pt-min)) + (cl-incf (car (aref syntax-ppss-stats 1))) + (cl-incf (cdr (aref syntax-ppss-stats 1)) (- pos pt-min)) (setq ppss (parse-partial-sexp pt-min pos))) ;; The OLD-* data can't be used. Consult the cache. (t @@ -188,8 +470,8 @@ Point is at POS when this function returns." ;; Use the best of OLD-POS and CACHE. (if (or (not old-pos) (< old-pos pt-min)) (setq pt-best pt-min ppss-best ppss) - (incf (car (aref syntax-ppss-stats 4))) - (incf (cdr (aref syntax-ppss-stats 4)) (- pos old-pos)) + (cl-incf (car (aref syntax-ppss-stats 4))) + (cl-incf (cdr (aref syntax-ppss-stats 4)) (- pos old-pos)) (setq pt-best old-pos ppss-best old-ppss)) ;; Use the `syntax-begin-function' if available. @@ -209,35 +491,34 @@ Point is at POS when this function returns." (funcall syntax-begin-function) ;; Make sure it's better. (> (point) pt-best)) - ;; Simple sanity check. + ;; Simple sanity checks. + (< (point) pos) ; backward-paragraph can fail here. (not (memq (get-text-property (point) 'face) '(font-lock-string-face font-lock-doc-face font-lock-comment-face)))) - (incf (car (aref syntax-ppss-stats 5))) - (incf (cdr (aref syntax-ppss-stats 5)) (- pos (point))) + (cl-incf (car (aref syntax-ppss-stats 5))) + (cl-incf (cdr (aref syntax-ppss-stats 5)) (- pos (point))) (setq pt-best (point) ppss-best nil)) (cond ;; Quick case when we found a nearby pos. ((< (- pos pt-best) syntax-ppss-max-span) - (incf (car (aref syntax-ppss-stats 2))) - (incf (cdr (aref syntax-ppss-stats 2)) (- pos pt-best)) + (cl-incf (car (aref syntax-ppss-stats 2))) + (cl-incf (cdr (aref syntax-ppss-stats 2)) (- pos pt-best)) (setq ppss (parse-partial-sexp pt-best pos nil nil ppss-best))) ;; Slow case: compute the state from some known position and ;; populate the cache so we won't need to do it again soon. (t - (incf (car (aref syntax-ppss-stats 3))) - (incf (cdr (aref syntax-ppss-stats 3)) (- pos pt-min)) + (cl-incf (car (aref syntax-ppss-stats 3))) + (cl-incf (cdr (aref syntax-ppss-stats 3)) (- pos pt-min)) ;; If `pt-min' is too far, add a few intermediate entries. (while (> (- pos pt-min) (* 2 syntax-ppss-max-span)) (setq ppss (parse-partial-sexp pt-min (setq pt-min (/ (+ pt-min pos) 2)) nil nil ppss)) - (let ((pair (cons pt-min ppss))) - (if cache-pred - (push pair (cdr cache-pred)) - (push pair syntax-ppss-cache)))) + (push (cons pt-min ppss) + (if cache-pred (cdr cache-pred) syntax-ppss-cache))) ;; Compute the actual return value. (setq ppss (parse-partial-sexp pt-min pos nil nil ppss)) @@ -300,5 +581,4 @@ Point is at POS when this function returns." (provide 'syntax) -;; arch-tag: 302f1eeb-e77c-4680-a8c5-c543e01161a5 ;;; syntax.el ends here diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el new file mode 100644 index 00000000000..94b3c1553e5 --- /dev/null +++ b/lisp/emacs-lisp/tabulated-list.el @@ -0,0 +1,535 @@ +;;; tabulated-list.el --- generic major mode for tabulated lists -*- lexical-binding: t -*- + +;; Copyright (C) 2011-2013 Free Software Foundation, Inc. + +;; Author: Chong Yidong <cyd@stupidchicken.com> +;; Keywords: extensions, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file defines Tabulated List mode, a generic major mode for +;; displaying lists of tabulated data, intended for other major modes +;; to inherit from. It provides several utility routines, e.g. for +;; pretty-printing lines of tabulated data to fit into the appropriate +;; columns. + +;; For usage information, see the documentation of `tabulated-list-mode'. + +;; This package originated from Tom Tromey's Package Menu mode, +;; extended and generalized to be used by other modes. + +;;; Code: + +;; The reason `tabulated-list-format' and other variables are +;; permanent-local is to make it convenient to switch to a different +;; major mode, switch back, and have the original Tabulated List data +;; still valid. See, for example, ebuff-menu.el. + +(defvar tabulated-list-format nil + "The format of the current Tabulated List mode buffer. +This should be a vector of elements (NAME WIDTH SORT . PROPS), +where: + - NAME is a string describing the column. + This is the label for the column in the header line. + Different columns must have non-`equal' names. + - WIDTH is the width to reserve for the column. + For the final element, its numerical value is ignored. + - SORT specifies how to sort entries by this column. + If nil, this column cannot be used for sorting. + If t, sort by comparing the string value printed in the column. + Otherwise, it should be a predicate function suitable for + `sort', accepting arguments with the same form as the elements + of `tabulated-list-entries'. + - PROPS is a plist of additional column properties. + Currently supported properties are: + - `:right-align': if non-nil, the column should be right-aligned. + - `:pad-right': Number of additional padding spaces to the + right of the column (defaults to 1 if omitted).") +(make-variable-buffer-local 'tabulated-list-format) +(put 'tabulated-list-format 'permanent-local t) + +(defvar tabulated-list-use-header-line t + "Whether the Tabulated List buffer should use a header line.") +(make-variable-buffer-local 'tabulated-list-use-header-line) + +(defvar tabulated-list-entries nil + "Entries displayed in the current Tabulated List buffer. +This should be either a function, or a list. +If a list, each element has the form (ID [DESC1 ... DESCN]), +where: + - ID is nil, or a Lisp object uniquely identifying this entry, + which is used to keep the cursor on the \"same\" entry when + rearranging the list. Comparison is done with `equal'. + + - Each DESC is a column descriptor, one for each column + specified in `tabulated-list-format'. A descriptor is either + a string, which is printed as-is, or a list (LABEL . PROPS), + which means to use `insert-text-button' to insert a text + button with label LABEL and button properties PROPS. + The string, or button label, must not contain any newline. + +If `tabulated-list-entries' is a function, it is called with no +arguments and must return a list of the above form.") +(make-variable-buffer-local 'tabulated-list-entries) +(put 'tabulated-list-entries 'permanent-local t) + +(defvar tabulated-list-padding 0 + "Number of characters preceding each Tabulated List mode entry. +By default, lines are padded with spaces, but you can use the +function `tabulated-list-put-tag' to change this.") +(make-variable-buffer-local 'tabulated-list-padding) +(put 'tabulated-list-padding 'permanent-local t) + +(defvar tabulated-list-revert-hook nil + "Hook run before reverting a Tabulated List buffer. +This is commonly used to recompute `tabulated-list-entries'.") + +(defvar tabulated-list-printer 'tabulated-list-print-entry + "Function for inserting a Tabulated List entry at point. +It is called with two arguments, ID and COLS. ID is a Lisp +object identifying the entry, and COLS is a vector of column +descriptors, as documented in `tabulated-list-entries'.") +(make-variable-buffer-local 'tabulated-list-printer) + +(defvar tabulated-list-sort-key nil + "Sort key for the current Tabulated List mode buffer. +If nil, no additional sorting is performed. +Otherwise, this should be a cons cell (NAME . FLIP). +NAME is a string matching one of the column names in +`tabulated-list-format' (the corresponding SORT entry in +`tabulated-list-format' then specifies how to sort). FLIP, if +non-nil, means to invert the resulting sort.") +(make-variable-buffer-local 'tabulated-list-sort-key) +(put 'tabulated-list-sort-key 'permanent-local t) + +(defsubst tabulated-list-get-id (&optional pos) + "Return the entry ID of the Tabulated List entry at POS. +The value is an ID object from `tabulated-list-entries', or nil. +POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'tabulated-list-id)) + +(defsubst tabulated-list-get-entry (&optional pos) + "Return the Tabulated List entry at POS. +The value is a vector of column descriptors, or nil if there is +no entry at POS. POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'tabulated-list-entry)) + +(defun tabulated-list-put-tag (tag &optional advance) + "Put TAG in the padding area of the current line. +TAG should be a string, with length <= `tabulated-list-padding'. +If ADVANCE is non-nil, move forward by one line afterwards." + (unless (stringp tag) + (error "Invalid argument to `tabulated-list-put-tag'")) + (unless (> tabulated-list-padding 0) + (error "Unable to tag the current line")) + (save-excursion + (beginning-of-line) + (when (tabulated-list-get-entry) + (let ((beg (point)) + (inhibit-read-only t)) + (forward-char tabulated-list-padding) + (insert-and-inherit + (let ((width (string-width tag))) + (if (<= width tabulated-list-padding) + (concat tag + (make-string (- tabulated-list-padding width) ?\s)) + (truncate-string-to-width tag tabulated-list-padding)))) + (delete-region beg (+ beg tabulated-list-padding))))) + (if advance + (forward-line))) + +(defvar tabulated-list-mode-map + (let ((map (copy-keymap special-mode-map))) + (set-keymap-parent map button-buffer-map) + (define-key map "n" 'next-line) + (define-key map "p" 'previous-line) + (define-key map "S" 'tabulated-list-sort) + (define-key map [follow-link] 'mouse-face) + (define-key map [mouse-2] 'mouse-select-window) + map) + "Local keymap for `tabulated-list-mode' buffers.") + +(defvar tabulated-list-sort-button-map + (let ((map (make-sparse-keymap))) + (define-key map [header-line mouse-1] 'tabulated-list-col-sort) + (define-key map [header-line mouse-2] 'tabulated-list-col-sort) + (define-key map [mouse-1] 'tabulated-list-col-sort) + (define-key map [mouse-2] 'tabulated-list-col-sort) + (define-key map "\C-m" 'tabulated-list-sort) + (define-key map [follow-link] 'mouse-face) + map) + "Local keymap for `tabulated-list-mode' sort buttons.") + +(defvar tabulated-list-glyphless-char-display + (let ((table (make-char-table 'glyphless-char-display nil))) + (set-char-table-parent table glyphless-char-display) + ;; Some text terminals can't display the Unicode arrows; be safe. + (aset table 9650 (cons nil "^")) + (aset table 9660 (cons nil "v")) + table) + "The `glyphless-char-display' table in Tabulated List buffers.") + +(defvar tabulated-list--header-string nil) +(defvar tabulated-list--header-overlay nil) + +(defun tabulated-list-init-header () + "Set up header line for the Tabulated List buffer." + ;; FIXME: Should share code with tabulated-list-print-col! + (let ((x (max tabulated-list-padding 0)) + (button-props `(help-echo "Click to sort by column" + mouse-face highlight + keymap ,tabulated-list-sort-button-map)) + (cols nil)) + (push (propertize " " 'display `(space :align-to ,x)) cols) + (dotimes (n (length tabulated-list-format)) + (let* ((col (aref tabulated-list-format n)) + (label (nth 0 col)) + (width (nth 1 col)) + (props (nthcdr 3 col)) + (pad-right (or (plist-get props :pad-right) 1)) + (right-align (plist-get props :right-align)) + (next-x (+ x pad-right width))) + (push + (cond + ;; An unsortable column + ((not (nth 2 col)) + (propertize label 'tabulated-list-column-name label)) + ;; The selected sort column + ((equal (car col) (car tabulated-list-sort-key)) + (apply 'propertize + (concat label + (cond + ((> (+ 2 (length label)) width) "") + ((cdr tabulated-list-sort-key) " ▲") + (t " ▼"))) + 'face 'bold + 'tabulated-list-column-name label + button-props)) + ;; Unselected sortable column. + (t (apply 'propertize label + 'tabulated-list-column-name label + button-props))) + cols) + (when right-align + (let ((shift (- width (string-width (car cols))))) + (when (> shift 0) + (setq cols + (cons (car cols) + (cons (propertize (make-string shift ?\s) + 'display + `(space :align-to ,(+ x shift))) + (cdr cols)))) + (setq x (+ x shift))))) + (if (> pad-right 0) + (push (propertize " " + 'display `(space :align-to ,next-x) + 'face 'fixed-pitch) + cols)) + (setq x next-x))) + (setq cols (apply 'concat (nreverse cols))) + (if tabulated-list-use-header-line + (setq header-line-format cols) + (setq header-line-format nil) + (set (make-local-variable 'tabulated-list--header-string) cols)))) + +(defun tabulated-list-print-fake-header () + "Insert a fake Tabulated List \"header line\" at the start of the buffer." + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (insert tabulated-list--header-string "\n") + (if tabulated-list--header-overlay + (move-overlay tabulated-list--header-overlay (point-min) (point)) + (set (make-local-variable 'tabulated-list--header-overlay) + (make-overlay (point-min) (point)))) + (overlay-put tabulated-list--header-overlay 'face 'underline))) + +(defun tabulated-list-revert (&rest ignored) + "The `revert-buffer-function' for `tabulated-list-mode'. +It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'." + (interactive) + (unless (derived-mode-p 'tabulated-list-mode) + (error "The current buffer is not in Tabulated List mode")) + (run-hooks 'tabulated-list-revert-hook) + (tabulated-list-print t)) + +(defun tabulated-list--column-number (name) + (let ((len (length tabulated-list-format)) + (n 0) + found) + (while (and (< n len) (null found)) + (if (equal (car (aref tabulated-list-format n)) name) + (setq found n)) + (setq n (1+ n))) + (or found + (error "No column named %s" name)))) + +(defun tabulated-list-print (&optional remember-pos) + "Populate the current Tabulated List mode buffer. +This sorts the `tabulated-list-entries' list if sorting is +specified by `tabulated-list-sort-key'. It then erases the +buffer and inserts the entries with `tabulated-list-printer'. + +Optional argument REMEMBER-POS, if non-nil, means to move point +to the entry with the same ID element as the current line." + (let ((inhibit-read-only t) + (entries (if (functionp tabulated-list-entries) + (funcall tabulated-list-entries) + tabulated-list-entries)) + entry-id saved-pt saved-col) + (and remember-pos + (setq entry-id (tabulated-list-get-id)) + (setq saved-col (current-column))) + (erase-buffer) + (unless tabulated-list-use-header-line + (tabulated-list-print-fake-header)) + ;; Sort the entries, if necessary. + (when (and tabulated-list-sort-key + (car tabulated-list-sort-key)) + (let* ((sort-column (car tabulated-list-sort-key)) + (n (tabulated-list--column-number sort-column)) + (sorter (nth 2 (aref tabulated-list-format n)))) + ;; Is the specified column sortable? + (when sorter + (when (eq sorter t) + (setq sorter ; Default sorter checks column N: + (lambda (A B) + (setq A (aref (cadr A) n)) + (setq B (aref (cadr B) n)) + (string< (if (stringp A) A (car A)) + (if (stringp B) B (car B)))))) + (setq entries (sort entries sorter)) + (if (cdr tabulated-list-sort-key) + (setq entries (nreverse entries))) + (unless (functionp tabulated-list-entries) + (setq tabulated-list-entries entries))))) + ;; Print the resulting list. + (dolist (elt entries) + (and entry-id + (equal entry-id (car elt)) + (setq saved-pt (point))) + (apply tabulated-list-printer elt)) + (set-buffer-modified-p nil) + ;; If REMEMBER-POS was specified, move to the "old" location. + (if saved-pt + (progn (goto-char saved-pt) + (move-to-column saved-col) + (recenter)) + (goto-char (point-min))))) + +(defun tabulated-list-print-entry (id cols) + "Insert a Tabulated List entry at point. +This is the default `tabulated-list-printer' function. ID is a +Lisp object identifying the entry to print, and COLS is a vector +of column descriptors." + (let ((beg (point)) + (x (max tabulated-list-padding 0)) + (ncols (length tabulated-list-format)) + (inhibit-read-only t)) + (if (> tabulated-list-padding 0) + (insert (make-string x ?\s))) + (dotimes (n ncols) + (setq x (tabulated-list-print-col n (aref cols n) x))) + (insert ?\n) + (put-text-property beg (point) 'tabulated-list-id id) + (put-text-property beg (point) 'tabulated-list-entry cols))) + +(defun tabulated-list-print-col (n col-desc x) + "Insert a specified Tabulated List entry at point. +N is the column number, COL-DESC is a column descriptor \(see +`tabulated-list-entries'), and X is the column number at point. +Return the column number after insertion." + ;; TODO: don't truncate to `width' if the next column is align-right + ;; and has some space left. + (let* ((format (aref tabulated-list-format n)) + (name (nth 0 format)) + (width (nth 1 format)) + (props (nthcdr 3 format)) + (pad-right (or (plist-get props :pad-right) 1)) + (right-align (plist-get props :right-align)) + (label (if (stringp col-desc) col-desc (car col-desc))) + (label-width (string-width label)) + (help-echo (concat (car format) ": " label)) + (opoint (point)) + (not-last-col (< (1+ n) (length tabulated-list-format)))) + ;; Truncate labels if necessary (except last column). + (and not-last-col + (> label-width width) + (setq label (truncate-string-to-width label width nil nil t) + label-width width)) + (setq label (bidi-string-mark-left-to-right label)) + (when (and right-align (> width label-width)) + (let ((shift (- width label-width))) + (insert (propertize (make-string shift ?\s) + 'display `(space :align-to ,(+ x shift)))) + (setq width (- width shift)) + (setq x (+ x shift)))) + (if (stringp col-desc) + (insert (propertize label 'help-echo help-echo)) + (apply 'insert-text-button label (cdr col-desc))) + (let ((next-x (+ x pad-right width))) + ;; No need to append any spaces if this is the last column. + (when not-last-col + (when (> pad-right 0) (insert (make-string pad-right ?\s))) + (insert (propertize + (make-string (- next-x x label-width pad-right) ?\s) + 'display `(space :align-to ,next-x)))) + (put-text-property opoint (point) 'tabulated-list-column-name name) + next-x))) + +(defun tabulated-list-delete-entry () + "Delete the Tabulated List entry at point. +Return a list (ID COLS), where ID is the ID of the deleted entry +and COLS is a vector of its column descriptors. Move point to +the beginning of the deleted entry. Return nil if there is no +entry at point. + +This function only changes the buffer contents; it does not alter +`tabulated-list-entries'." + ;; Assume that each entry occupies one line. + (let* ((id (tabulated-list-get-id)) + (cols (tabulated-list-get-entry)) + (inhibit-read-only t)) + (when cols + (delete-region (line-beginning-position) (1+ (line-end-position))) + (list id cols)))) + +(defun tabulated-list-set-col (col desc &optional change-entry-data) + "Change the Tabulated List entry at point, setting COL to DESC. +COL is the column number to change, or the name of the column to change. +DESC is the new column descriptor, which is inserted via +`tabulated-list-print-col'. + +If CHANGE-ENTRY-DATA is non-nil, modify the underlying entry data +by setting the appropriate slot of the vector originally used to +print this entry. If `tabulated-list-entries' has a list value, +this is the vector stored within it." + (let* ((opoint (point)) + (eol (line-end-position)) + (pos (line-beginning-position)) + (id (tabulated-list-get-id pos)) + (entry (tabulated-list-get-entry pos)) + (prop 'tabulated-list-column-name) + (inhibit-read-only t) + name) + (cond ((numberp col) + (setq name (car (aref tabulated-list-format col)))) + ((stringp col) + (setq name col + col (tabulated-list--column-number col))) + (t + (error "Invalid column %s" col))) + (unless entry + (error "No Tabulated List entry at position %s" opoint)) + (unless (equal (get-text-property pos prop) name) + (while (and (setq pos + (next-single-property-change pos prop nil eol)) + (< pos eol) + (not (equal (get-text-property pos prop) name))))) + (when (< pos eol) + (delete-region pos (next-single-property-change pos prop nil eol)) + (goto-char pos) + (tabulated-list-print-col col desc (current-column)) + (if change-entry-data + (aset entry col desc)) + (put-text-property pos (point) 'tabulated-list-id id) + (put-text-property pos (point) 'tabulated-list-entry entry) + (goto-char opoint)))) + +(defun tabulated-list-col-sort (&optional e) + "Sort Tabulated List entries by the column of the mouse click E." + (interactive "e") + (let* ((pos (event-start e)) + (obj (posn-object pos))) + (with-current-buffer (window-buffer (posn-window pos)) + (tabulated-list--sort-by-column-name + (get-text-property (if obj (cdr obj) (posn-point pos)) + 'tabulated-list-column-name + (car obj)))))) + +(defun tabulated-list-sort (&optional n) + "Sort Tabulated List entries by the column at point. +With a numeric prefix argument N, sort the Nth column." + (interactive "P") + (let ((name (if n + (car (aref tabulated-list-format n)) + (get-text-property (point) + 'tabulated-list-column-name)))) + (tabulated-list--sort-by-column-name name))) + +(defun tabulated-list--sort-by-column-name (name) + (when (and name (derived-mode-p 'tabulated-list-mode)) + ;; Flip the sort order on a second click. + (if (equal name (car tabulated-list-sort-key)) + (setcdr tabulated-list-sort-key + (not (cdr tabulated-list-sort-key))) + (setq tabulated-list-sort-key (cons name nil))) + (tabulated-list-init-header) + (tabulated-list-print t))) + +;;; The mode definition: + +(define-derived-mode tabulated-list-mode special-mode "Tabulated" + "Generic major mode for browsing a list of items. +This mode is usually not used directly; instead, other major +modes are derived from it, using `define-derived-mode'. + +In this major mode, the buffer is divided into multiple columns, +which are labeled using the header line. Each non-empty line +belongs to one \"entry\", and the entries can be sorted according +to their column values. + +An inheriting mode should usually do the following in their body: + + - Set `tabulated-list-format', specifying the column format. + - Set `tabulated-list-revert-hook', if the buffer contents need + to be specially recomputed prior to `revert-buffer'. + - Maybe set a `tabulated-list-entries' function (see below). + - Maybe set `tabulated-list-printer' (see below). + - Maybe set `tabulated-list-padding'. + - Call `tabulated-list-init-header' to initialize `header-line-format' + according to `tabulated-list-format'. + +An inheriting mode is usually accompanied by a \"list-FOO\" +command (e.g. `list-packages', `list-processes'). This command +creates or switches to a buffer and enables the major mode in +that buffer. If `tabulated-list-entries' is not a function, the +command should initialize it to a list of entries for displaying. +Finally, it should call `tabulated-list-print'. + +`tabulated-list-print' calls the printer function specified by +`tabulated-list-printer', once for each entry. The default +printer is `tabulated-list-print-entry', but a mode that keeps +data in an ewoc may instead specify a printer function (e.g., one +that calls `ewoc-enter-last'), with `tabulated-list-print-entry' +as the ewoc pretty-printer." + (setq truncate-lines t) + (setq buffer-read-only t) + (set (make-local-variable 'revert-buffer-function) + 'tabulated-list-revert) + (set (make-local-variable 'glyphless-char-display) + tabulated-list-glyphless-char-display)) + +(put 'tabulated-list-mode 'mode-class 'special) + +(provide 'tabulated-list) + +;; Local Variables: +;; coding: utf-8 +;; End: + +;;; tabulated-list.el ends here diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index a3b144b69dc..02023b957a5 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -1,11 +1,11 @@ ;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> ;; Keywords: spreadsheet lisp utility +;; Package: testcover ;; 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 @@ -721,5 +721,4 @@ spreadsheet files with invalid formatting." ;;Could do this here: (testcover-end "ses.el") (message "Done")) -;; arch-tag: 87052ba4-5cf8-46cf-9375-fe245f3360b8 ;; testcover-ses.el ends here. diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el index d389b40ae39..e557e1c30c1 100644 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -1,10 +1,11 @@ ;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> ;; Keywords: safety lisp utility +;; Package: testcover ;; This file is part of GNU Emacs. @@ -28,13 +29,13 @@ ;;;These forms are all considered safe (defconst testcover-unsafep-safe '(((lambda (x) (* x 2)) 14) - (apply 'cdr (mapcar '(lambda (x) (car x)) y)) + (apply 'cdr (mapcar (lambda (x) (car x)) y)) (cond ((= x 4) 5) (t 27)) (condition-case x (car y) (error (car x))) (dolist (x y) (message "here: %s" x)) (dotimes (x 14 (* x 2)) (message "here: %d" x)) (let (x) (dolist (y '(1 2 3) (1+ y)) (push y x))) - (let (x) (apply '(lambda (x) (* x 2)) 14)) + (let (x) (apply (lambda (x) (* x 2)) 14)) (let ((x '(2))) (push 1 x) (pop x) (add-to-list 'x 2)) (let ((x 1) (y 2)) (setq x (+ x y))) (let ((x 1)) (let ((y (+ x 3))) (* x y))) @@ -89,7 +90,7 @@ . (function kill-buffer)) ( (mapcar x y) . (unquoted x)) - ( (mapcar '(lambda (x) (rename-file x "x")) '("unsafep.el")) + ( (mapcar (lambda (x) (rename-file x "x")) '("unsafep.el")) . (function rename-file)) ( (mapconcat x1 x2 " ") . (unquoted x1)) @@ -99,7 +100,7 @@ . (risky-local-variable format-alist)) ( (setq buffer-display-count (delete-file "x")) . (function delete-file)) - ;;These are actualy safe (they signal errors) + ;;These are actually safe (they signal errors) ( (apply '(x) '(1 2 3)) . (function (x))) ( (let (((x))) 1) @@ -137,5 +138,4 @@ (testcover-end "unsafep.el") (message "Done")) -;; arch-tag: a7616c27-1998-47ae-9304-76d1439dbf29 ;; testcover-unsafep.el ends here. diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index 76a2c417a19..f6bd26e9f34 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -1,6 +1,6 @@ ;;;; testcover.el -- Visual code-coverage tool -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> @@ -28,7 +28,7 @@ ;; * Use `testcover-mark-all' to add overlay "splotches" to the Lisp file's ;; buffer to show where coverage is lacking. Normally, a red splotch ;; indicates the form was never evaluated; a brown splotch means it always -;; evaluted to the same value. +;; evaluated to the same value. ;; * Use `testcover-next-mark' (bind it to a key!) to jump to the next spot ;; that has a splotch. @@ -220,7 +220,7 @@ non-nil, byte-compiles each function after instrumenting." (defun testcover-reinstrument (form) "Reinstruments FORM to use testcover instead of edebug. This function modifies the list that FORM points to. Result is nil if -FORM should return multiple vlues, t if should always return same +FORM should return multiple values, t if should always return same value, 'maybe if either is acceptable." (let ((fun (car-safe form)) id val) @@ -270,9 +270,9 @@ value, 'maybe if either is acceptable." (setq id (nth 2 form)) (setcdr form (nthcdr 2 form)) (setq val (testcover-reinstrument (nth 2 form))) - (if (eq val t) - (setcar form 'testcover-1value) - (setcar form 'testcover-after)) + (setcar form (if (eq val t) + 'testcover-1value + 'testcover-after)) (when val ;;1-valued or potentially 1-valued (aset testcover-vector id '1value)) @@ -359,9 +359,9 @@ value, 'maybe if either is acceptable." ,(nth 3 (cadr form)))) t) (t - (if (eq (car (cadr form)) 'edebug-after) - (setq id (car (nth 3 (cadr form)))) - (setq id (car (cadr form)))) + (setq id (car (if (eq (car (cadr form)) 'edebug-after) + (nth 3 (cadr form)) + (cadr form)))) (let ((testcover-1value-functions (cons id testcover-1value-functions))) (testcover-reinstrument (cadr form)))))) @@ -379,9 +379,9 @@ value, 'maybe if either is acceptable." ,(nth 3 (cadr form)))) 'maybe) (t - (if (eq (car (cadr form)) 'edebug-after) - (setq id (car (nth 3 (cadr form)))) - (setq id (car (cadr form)))) + (setq id (car (if (eq (car (cadr form)) 'edebug-after) + (nth 3 (cadr form)) + (cadr form)))) (let ((testcover-noreturn-functions (cons id testcover-noreturn-functions))) (testcover-reinstrument (cadr form)))))) @@ -430,7 +430,7 @@ FUN should be `testcover-reinstrument' for compositional functions, "Turn off instrumentation of all macros and functions in FILENAME." (interactive "fStop covering file: ") (let ((buf (find-file-noselect filename))) - (eval-buffer buf t))) + (eval-buffer buf))) ;;;========================================================================= @@ -447,6 +447,12 @@ binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM (defun testcover-after (idx val) "Internal function for coverage testing. Returns VAL after installing it in `testcover-vector' at offset IDX." + (declare (gv-expander (lambda (do) + (gv-letplace (getter setter) val + (funcall do getter + (lambda (store) + `(progn (testcover-after ,idx ,getter) + ,(funcall setter store)))))))) (cond ((eq (aref testcover-vector idx) 'unknown) (aset testcover-vector idx val)) @@ -509,7 +515,7 @@ eliminated by adding more test cases." (set-buffer-modified-p changed)))) (defun testcover-mark-all (&optional buffer) - "Mark all forms in BUFFER that did not get completley tested during + "Mark all forms in BUFFER that did not get completely tested during coverage tests. This function creates many overlays." (interactive "bMark forms in buffer: ") (if buffer @@ -534,5 +540,4 @@ coverage tests. This function creates many overlays." (goto-char (next-overlay-change (point))) (end-of-line)) -;; arch-tag: 72324a4a-4a2e-4142-9249-cc56d6757588 ;; testcover.el ends here. diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 4904757c514..3eaacd24ec8 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -1,9 +1,9 @@ ;;; timer.el --- run a function with args at some time in future -;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1996, 2001-2013 Free Software Foundation, Inc. ;; Maintainer: FSF +;; Package: emacs ;; This file is part of GNU Emacs. @@ -29,40 +29,48 @@ ;; Layout of a timer vector: ;; [triggered-p high-seconds low-seconds usecs repeat-delay -;; function args idle-delay] +;; function args idle-delay psecs] ;; triggered-p is nil if the timer is active (waiting to be triggered), ;; t if it is inactive ("already triggered", in theory) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) -(defstruct (timer +(cl-defstruct (timer (:constructor nil) (:copier nil) (:constructor timer-create ()) (:type vector) (:conc-name timer--)) (triggered t) - high-seconds low-seconds usecs repeat-delay function args idle-delay) + high-seconds low-seconds usecs repeat-delay function args idle-delay psecs) (defun timerp (object) "Return t if OBJECT is a timer." - (and (vectorp object) (= (length object) 8))) + (and (vectorp object) (= (length object) 9))) ;; Pseudo field `time'. (defun timer--time (timer) (list (timer--high-seconds timer) (timer--low-seconds timer) - (timer--usecs timer))) + (timer--usecs timer) + (timer--psecs timer))) -(defsetf timer--time +(gv-define-simple-setter timer--time (lambda (timer time) (or (timerp timer) (error "Invalid timer")) (setf (timer--high-seconds timer) (pop time)) - (setf (timer--low-seconds timer) - (if (consp time) (car time) time)) - (setf (timer--usecs timer) (or (and (consp time) (consp (cdr time)) - (cadr time)) - 0)))) + (let ((low time) (usecs 0) (psecs 0)) + (if (consp time) + (progn + (setq low (pop time)) + (if time + (progn + (setq usecs (pop time)) + (if time + (setq psecs (car time))))))) + (setf (timer--low-seconds timer) low) + (setf (timer--usecs timer) usecs) + (setf (timer--psecs timer) psecs)))) (defun timer-set-time (timer time &optional delta) @@ -77,7 +85,7 @@ fire repeatedly that many seconds apart." (defun timer-set-idle-time (timer secs &optional repeat) "Set the trigger idle time of TIMER to SECS. SECS may be an integer, floating point number, or the internal -time format (HIGH LOW USECS) returned by, e.g., `current-idle-time'. +time format returned by, e.g., `current-idle-time'. If optional third argument REPEAT is non-nil, make the timer fire each time Emacs is idle for that many seconds." (if (consp secs) @@ -91,74 +99,46 @@ fire each time Emacs is idle for that many seconds." "Yield the next value after TIME that is an integral multiple of SECS. More precisely, the next value, after TIME, that is an integral multiple of SECS seconds since the epoch. SECS may be a fraction." - (let ((time-base (ash 1 16))) - (if (fboundp 'atan) - ;; Use floating point, taking care to not lose precision. - (let* ((float-time-base (float time-base)) - (million 1000000.0) - (time-usec (+ (* million - (+ (* float-time-base (nth 0 time)) - (nth 1 time))) - (nth 2 time))) - (secs-usec (* million secs)) - (mod-usec (mod time-usec secs-usec)) - (next-usec (+ (- time-usec mod-usec) secs-usec)) - (time-base-million (* float-time-base million))) - (list (floor next-usec time-base-million) - (floor (mod next-usec time-base-million) million) - (floor (mod next-usec million)))) - ;; Floating point is not supported. - ;; Use integer arithmetic, avoiding overflow if possible. - (let* ((mod-sec (mod (+ (* (mod time-base secs) - (mod (nth 0 time) secs)) - (nth 1 time)) - secs)) - (next-1-sec (+ (- (nth 1 time) mod-sec) secs))) - (list (+ (nth 0 time) (floor next-1-sec time-base)) - (mod next-1-sec time-base) - 0))))) - -(defun timer-relative-time (time secs &optional usecs) - "Advance TIME by SECS seconds and optionally USECS microseconds. -SECS may be either an integer or a floating point number." - ;; FIXME: we should just use (time-add time (list 0 secs usecs)) - (let ((high (car time)) - (low (if (consp (cdr time)) (nth 1 time) (cdr time))) - (micro (if (numberp (car-safe (cdr-safe (cdr time)))) - (nth 2 time) - 0))) - ;; Add - (if usecs (setq micro (+ micro usecs))) - (if (floatp secs) - (setq micro (+ micro (floor (* 1000000 (- secs (floor secs))))))) - (setq low (+ low (floor secs))) - - ;; Normalize - ;; `/' rounds towards zero while `mod' returns a positive number, - ;; so we can't rely on (= a (+ (* 100 (/ a 100)) (mod a 100))). - (setq low (+ low (/ micro 1000000) (if (< micro 0) -1 0))) - (setq micro (mod micro 1000000)) - (setq high (+ high (/ low 65536) (if (< low 0) -1 0))) - (setq low (logand low 65535)) - - (list high low (and (/= micro 0) micro)))) + (let* ((trillion 1e12) + (time-sec (+ (nth 1 time) + (* 65536.0 (nth 0 time)))) + (delta-sec (mod (- time-sec) secs)) + (next-sec (+ time-sec (ffloor delta-sec))) + (next-sec-psec (ffloor (* trillion (mod delta-sec 1)))) + (sub-time-psec (+ (or (nth 3 time) 0) + (* 1e6 (nth 2 time)))) + (psec-diff (- sub-time-psec next-sec-psec))) + (if (and (<= next-sec time-sec) (< 0 psec-diff)) + (setq next-sec-psec (+ sub-time-psec + (mod (- psec-diff) (* trillion secs))))) + (setq next-sec (+ next-sec (floor next-sec-psec trillion))) + (setq next-sec-psec (mod next-sec-psec trillion)) + (list (floor next-sec 65536) + (floor (mod next-sec 65536)) + (floor next-sec-psec 1000000) + (floor (mod next-sec-psec 1000000))))) + +(defun timer-relative-time (time secs &optional usecs psecs) + "Advance TIME by SECS seconds and optionally USECS nanoseconds +and PSECS picoseconds. SECS may be either an integer or a +floating point number." + (let ((delta (if (floatp secs) + (seconds-to-time secs) + (list (floor secs 65536) (mod secs 65536))))) + (if (or usecs psecs) + (setq delta (time-add delta (list 0 0 (or usecs 0) (or psecs 0))))) + (time-add time delta))) (defun timer--time-less-p (t1 t2) "Say whether time value T1 is less than time value T2." - ;; FIXME just use time-less-p. - (destructuring-bind (high1 low1 micro1) (timer--time t1) - (destructuring-bind (high2 low2 micro2) (timer--time t2) - (or (< high1 high2) - (and (= high1 high2) - (or (< low1 low2) - (and (= low1 low2) - (< micro1 micro2)))))))) - -(defun timer-inc-time (timer secs &optional usecs) - "Increment the time set in TIMER by SECS seconds and USECS microseconds. -SECS may be a fraction. If USECS is omitted, that means it is zero." + (time-less-p (timer--time t1) (timer--time t2))) + +(defun timer-inc-time (timer secs &optional usecs psecs) + "Increment the time set in TIMER by SECS seconds, USECS nanoseconds, +and PSECS picoseconds. SECS may be a fraction. If USECS or PSECS are +omitted, they are treated as zero." (setf (timer--time timer) - (timer-relative-time (timer--time timer) secs usecs))) + (timer-relative-time (timer--time timer) secs usecs psecs))) (defun timer-set-time-with-usecs (timer time usecs &optional delta) "Set the trigger time of TIMER to TIME plus USECS. @@ -166,13 +146,13 @@ TIME must be in the internal format returned by, e.g., `current-time'. The microsecond count from TIME is ignored, and USECS is used instead. If optional fourth argument DELTA is a positive number, make the timer fire repeatedly that many seconds apart." + (declare (obsolete "use `timer-set-time' and `timer-inc-time' instead." + "22.1")) (setf (timer--time timer) time) (setf (timer--usecs timer) usecs) + (setf (timer--psecs timer) 0) (setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta)) timer) -(make-obsolete 'timer-set-time-with-usecs - "use `timer-set-time' and `timer-inc-time' instead." - "22.1") (defun timer-set-function (timer function &optional args) "Make TIMER call FUNCTION with optional ARGS when triggering." @@ -187,6 +167,7 @@ fire repeatedly that many seconds apart." (integerp (timer--high-seconds timer)) (integerp (timer--low-seconds timer)) (integerp (timer--usecs timer)) + (integerp (timer--psecs timer)) (timer--function timer)) (let ((timers (if idle timer-idle-list timer-list)) last) @@ -200,35 +181,42 @@ fire repeatedly that many seconds apart." (setcdr reuse-cell timers)) (setq reuse-cell (cons timer timers))) ;; Insert new timer after last which possibly means in front of queue. - (if last - (setcdr last reuse-cell) - (if idle - (setq timer-idle-list reuse-cell) - (setq timer-list reuse-cell))) + (cond (last (setcdr last reuse-cell)) + (idle (setq timer-idle-list reuse-cell)) + (t (setq timer-list reuse-cell))) (setf (timer--triggered timer) triggered-p) (setf (timer--idle-delay timer) idle) nil) (error "Invalid or uninitialized timer"))) -(defun timer-activate (timer &optional triggered-p reuse-cell idle) - "Put TIMER on the list of active timers. - -If TRIGGERED-P is t, that means to make the timer inactive -\(put it on the list, but mark it as already triggered). -To remove from the list, use `cancel-timer'. +(defun timer-activate (timer &optional triggered-p reuse-cell) + "Insert TIMER into `timer-list'. +If TRIGGERED-P is t, make TIMER inactive (put it on the list, but +mark it as already triggered). To remove it, use `cancel-timer'. -REUSE-CELL, if non-nil, is a cons cell to reuse instead -of allocating a new one." +REUSE-CELL, if non-nil, is a cons cell to reuse when inserting +TIMER into `timer-list' (usually a cell removed from that list by +`cancel-timer-internal'; using this reduces consing for repeat +timers). If nil, allocate a new cell." (timer--activate timer triggered-p reuse-cell nil)) (defun timer-activate-when-idle (timer &optional dont-wait reuse-cell) - "Arrange to activate TIMER whenever Emacs is next idle. -If optional argument DONT-WAIT is non-nil, then enable the -timer to activate immediately, or at the right time, if Emacs -is already idle. - -REUSE-CELL, if non-nil, is a cons cell to reuse instead -of allocating a new one." + "Insert TIMER into `timer-idle-list'. +This arranges to activate TIMER whenever Emacs is next idle. +If optional argument DONT-WAIT is non-nil, set TIMER to activate +immediately \(see below\), or at the right time, if Emacs is +already idle. + +REUSE-CELL, if non-nil, is a cons cell to reuse when inserting +TIMER into `timer-idle-list' (usually a cell removed from that +list by `cancel-timer-internal'; using this reduces consing for +repeat timers). If nil, allocate a new cell. + +Using non-nil DONT-WAIT is not recommended when activating an +idle timer from an idle timer handler, if the timer being +activated has an idleness time that is smaller or equal to +the time of the current timer. That's because the activated +timer will fire right away." (timer--activate timer (not dont-wait) reuse-cell 'idle)) (defalias 'disable-timeout 'cancel-timer) @@ -273,21 +261,20 @@ and idle timers such as are scheduled by `run-with-idle-timer'." (defvar timer-event-last-2 nil "Third-to-last timer that was run.") -(defvar timer-max-repeats 10 - "*Maximum number of times to repeat a timer, if many repeats are delayed. +(defcustom timer-max-repeats 10 + "Maximum number of times to repeat a timer, if many repeats are delayed. Timer invocations can be delayed because Emacs is suspended or busy, or because the system's time changes. If such an occurrence makes it appear that many invocations are overdue, this variable controls -how many will really happen.") +how many will really happen." + :type 'integer + :group 'internal) (defun timer-until (timer time) "Calculate number of seconds from when TIMER will run, until TIME. TIMER is a timer, and stands for the time when its next repeat is scheduled. TIME is a time-list." - ;; FIXME: (float-time (time-subtract (timer--time timer) time)) - (let ((high (- (car time) (timer--high-seconds timer))) - (low (- (nth 1 time) (timer--low-seconds timer)))) - (+ low (* high 65536)))) + (- (float-time time) (float-time (timer--time timer)))) (defun timer-event-handler (timer) "Call the handler for the timer TIMER. @@ -321,7 +308,11 @@ This function is called, by name, directly by the C code." ;; We do this after rescheduling so that the handler function ;; can cancel its own timer successfully with cancel-timer. (condition-case nil - (apply (timer--function timer) (timer--args timer)) + ;; Timer functions should not change the current buffer. + ;; If they do, all kinds of nasty surprises can happen, + ;; and it can be hellish to track down their source. + (save-current-buffer + (apply (timer--function timer) (timer--args timer))) (error nil)) (if retrigger (setf (timer--triggered timer) nil))) @@ -416,9 +407,11 @@ This function is for compatibility; see also `run-with-timer'." "Perform an action the next time Emacs is idle for SECS seconds. The action is to call FUNCTION with arguments ARGS. SECS may be an integer, a floating point number, or the internal -time format (HIGH LOW USECS) returned by, e.g., `current-idle-time'. +time format returned by, e.g., `current-idle-time'. If Emacs is currently idle, and has been idle for N seconds (N < SECS), -then it will call FUNCTION in SECS - N seconds from now. +then it will call FUNCTION in SECS - N seconds from now. Using +SECS <= N is not recommended if this function is invoked from an idle +timer, because FUNCTION will then be called immediately. If REPEAT is non-nil, do the action each time Emacs has been idle for exactly SECS seconds (that is, only once for each time Emacs becomes idle). @@ -434,12 +427,6 @@ This function returns a timer object which you can use in `cancel-timer'." (timer-activate-when-idle timer t) timer)) -(defun with-timeout-handler (tag) - "This is the timer function used for the timer made by `with-timeout'." - (throw tag 'timeout)) - -(put 'with-timeout 'lisp-indent-function 1) - (defvar with-timeout-timers nil "List of all timers used by currently pending `with-timeout' calls.") @@ -451,23 +438,27 @@ event (such as keyboard input, input from subprocesses, or a certain time); if the program loops without waiting in any way, the timeout will not be detected. \n(fn (SECONDS TIMEOUT-FORMS...) BODY)" + (declare (indent 1) (debug ((form body) body))) (let ((seconds (car list)) - (timeout-forms (cdr list))) - `(let ((with-timeout-tag (cons nil nil)) - with-timeout-value with-timeout-timer - (with-timeout-timers with-timeout-timers)) - (if (catch with-timeout-tag - (progn - (setq with-timeout-timer - (run-with-timer ,seconds nil - 'with-timeout-handler - with-timeout-tag)) - (push with-timeout-timer with-timeout-timers) - (setq with-timeout-value (progn . ,body)) - nil)) - (progn . ,timeout-forms) - (cancel-timer with-timeout-timer) - with-timeout-value)))) + (timeout-forms (cdr list)) + (timeout (make-symbol "timeout"))) + `(let ((-with-timeout-value- + (catch ',timeout + (let* ((-with-timeout-timer- + (run-with-timer ,seconds nil + (lambda () (throw ',timeout ',timeout)))) + (with-timeout-timers + (cons -with-timeout-timer- with-timeout-timers))) + (unwind-protect + (progn ,@body) + (cancel-timer -with-timeout-timer-)))))) + ;; It is tempting to avoid the `if' altogether and instead run + ;; timeout-forms in the timer, just before throwing `timeout'. + ;; But that would mean that timeout-forms are run in the deeper + ;; dynamic context of the timer, with inhibit-quit set etc... + (if (eq -with-timeout-value- ',timeout) + (progn ,@timeout-forms) + -with-timeout-value-)))) (defun with-timeout-suspend () "Stop the clock for `with-timeout'. Used by debuggers. @@ -539,5 +530,4 @@ If the user does not answer after SECONDS seconds, return DEFAULT-VALUE." (provide 'timer) -;; arch-tag: b1a9237b-7787-4382-9e46-8f2c3b3273e0 ;;; timer.el ends here diff --git a/lisp/emacs-lisp/tq.el b/lisp/emacs-lisp/tq.el index b717535d146..d308ce694d2 100644 --- a/lisp/emacs-lisp/tq.el +++ b/lisp/emacs-lisp/tq.el @@ -1,7 +1,7 @@ ;;; tq.el --- utility to maintain a transaction queue -;; Copyright (C) 1985, 1986, 1987, 1992, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1987, 1992, 2001-2013 Free Software Foundation, +;; Inc. ;; Author: Scott Draves <spot@cs.cmu.edu> ;; Maintainer: FSF @@ -167,5 +167,4 @@ This produces more reliable results with some processes." (provide 'tq) -;; arch-tag: 65dea08c-4edd-4cde-83a5-e8a15b993b79 ;;; tq.el ends here diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 690acd47e4b..3e55b7c88fa 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -1,7 +1,6 @@ ;;; trace.el --- tracing facility for Emacs Lisp functions -;; Copyright (C) 1993, 1998, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1998, 2000-2013 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: FSF @@ -255,7 +254,9 @@ 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." +display oriented stuff, use `trace-function-background' instead. + +To untrace a function, use `untrace-function' or `untrace-all'." (interactive (list (intern (completing-read "Trace function: " obarray 'fboundp t)) @@ -272,7 +273,9 @@ and activates it together with any other advice there might be. The trace output goes to BUFFER quietly, without changing the window or buffer configuration. -BUFFER defaults to `trace-buffer'." +BUFFER defaults to `trace-buffer'. + +To untrace a function, use `untrace-function' or `untrace-all'." (interactive (list (intern @@ -286,7 +289,7 @@ 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))) + (list (ad-read-advised-function "Untrace function" 'trace-is-traced))) (when (trace-is-traced function) (ad-remove-advice function 'around trace-advice-name) (ad-update function))) @@ -299,5 +302,4 @@ was not traced this is a noop." (provide 'trace) -;; arch-tag: cfd170a7-4932-4331-8c8b-b7151942e5a1 ;;; trace.el ends here diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 2f69042f3c5..699392fb349 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -1,6 +1,6 @@ ;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> @@ -202,6 +202,9 @@ UNSAFEP-VARS is a list of symbols with local bindings." (dolist (x (nthcdr 3 form)) (setq reason (unsafep-progn (cdr x))) (if reason (throw 'unsafep reason)))))) + ((eq fun '\`) + ;; Backquoted form - safe if its expansion is. + (unsafep (cdr (backquote-process (cadr form))))) (t ;;First unsafep-function call above wasn't nil, no special case applies reason))))) @@ -258,5 +261,4 @@ If TO-BIND is t, check whether SYM is safe to bind." (local-variable-p sym))) `(global-variable ,sym)))) -;; arch-tag: 6216f98b-eb8f-467a-9c33-7a7644f50658 ;;; unsafep.el ends here diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index b39f42b4ec0..4c20a0974d1 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -1,6 +1,6 @@ ;;; warnings.el --- log and display warnings -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal @@ -64,8 +64,8 @@ Level :debug is ignored by default (see `warning-minimum-level').") (critical . :emergency) (alarm . :emergency)) "Alist of aliases for severity levels for `display-warning'. -Each element looks like (ALIAS . LEVEL) and defines -ALIAS as equivalent to LEVEL. LEVEL must be defined in `warning-levels'; +Each element looks like (ALIAS . LEVEL) and defines ALIAS as +equivalent to LEVEL. LEVEL must be defined in `warning-levels'; it may not itself be an alias.") (defcustom warning-minimum-level :warning @@ -119,9 +119,9 @@ See also `warning-suppress-log-types'." :type '(repeat (repeat symbol)) :version "22.1") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-prefix-function nil "Function to generate warning prefixes. @@ -132,30 +132,30 @@ The warnings buffer is current when this function is called and the function can insert text in it. This text becomes the beginning of the warning.") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-series nil "Non-nil means treat multiple `display-warning' calls as a series. A marker indicates a position in the warnings buffer which is the start of the current series; it means that additional warnings in the same buffer should not move point. -t means the next warning begins a series (and stores a marker here). +If t, the next warning begins a series (and stores a marker here). A symbol with a function definition is like t, except also call that function before the next warning.") (put 'warning-series 'risky-local-variable t) -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-fill-prefix nil "Non-nil means fill each warning text using this string as `fill-prefix'.") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-type-format (purecopy " (%s)") "Format for displaying the warning type in the warning message. @@ -235,12 +235,14 @@ See also `warning-series', `warning-prefix-function' and (warning-suppress-p type warning-suppress-log-types) (let* ((typename (if (consp type) (car type) type)) (old (get-buffer buffer-name)) - (buffer (get-buffer-create buffer-name)) + (buffer (or old (get-buffer-create buffer-name))) (level-info (assq level warning-levels)) start end) (with-current-buffer buffer ;; If we created the buffer, disable undo. (unless old + (special-mode) + (setq buffer-read-only t) (setq buffer-undo-list t)) (goto-char (point-max)) (when (and warning-series (symbolp warning-series)) @@ -248,60 +250,61 @@ See also `warning-series', `warning-prefix-function' and (prog1 (point-marker) (unless (eq warning-series t) (funcall warning-series))))) - (unless (bolp) - (newline)) - (setq start (point)) - (if warning-prefix-function - (setq level-info (funcall warning-prefix-function - level level-info))) - (insert (format (nth 1 level-info) - (format warning-type-format typename)) - message) - (newline) - (when (and warning-fill-prefix (not (string-match "\n" message))) - (let ((fill-prefix warning-fill-prefix) - (fill-column 78)) - (fill-region start (point)))) - (setq end (point)) + (let ((inhibit-read-only t)) + (unless (bolp) + (newline)) + (setq start (point)) + (if warning-prefix-function + (setq level-info (funcall warning-prefix-function + level level-info))) + (insert (format (nth 1 level-info) + (format warning-type-format typename)) + message) + (newline) + (when (and warning-fill-prefix (not (string-match "\n" message))) + (let ((fill-prefix warning-fill-prefix) + (fill-column 78)) + (fill-region start (point)))) + (setq end (point))) (when (and (markerp warning-series) (eq (marker-buffer warning-series) buffer)) (goto-char warning-series))) (if (nth 2 level-info) (funcall (nth 2 level-info))) - (cond (noninteractive - ;; Noninteractively, take the text we inserted - ;; in the warnings buffer and print it. - ;; Do this unconditionally, since there is no way - ;; to view logged messages unless we output them. - (with-current-buffer buffer - (save-excursion - ;; Don't include the final newline in the arg - ;; to `message', because it adds a newline. - (goto-char end) - (if (bolp) - (forward-char -1)) - (message "%s" (buffer-substring start (point)))))) - ((and (daemonp) (null after-init-time)) - ;; Warnings assigned during daemon initialization go into - ;; the messages buffer. - (message "%s" - (with-current-buffer buffer - (save-excursion - (goto-char end) - (if (bolp) - (forward-char -1)) - (buffer-substring start (point)))))) - (t - ;; Interactively, decide whether the warning merits - ;; immediate display. - (or (< (warning-numeric-level level) - (warning-numeric-level warning-minimum-level)) - (warning-suppress-p type warning-suppress-types) - (let ((window (display-buffer buffer))) - (when (and (markerp warning-series) - (eq (marker-buffer warning-series) buffer)) - (set-window-start window warning-series)) - (sit-for 0)))))))) + (cond (noninteractive + ;; Noninteractively, take the text we inserted + ;; in the warnings buffer and print it. + ;; Do this unconditionally, since there is no way + ;; to view logged messages unless we output them. + (with-current-buffer buffer + (save-excursion + ;; Don't include the final newline in the arg + ;; to `message', because it adds a newline. + (goto-char end) + (if (bolp) + (forward-char -1)) + (message "%s" (buffer-substring start (point)))))) + ((and (daemonp) (null after-init-time)) + ;; Warnings assigned during daemon initialization go into + ;; the messages buffer. + (message "%s" + (with-current-buffer buffer + (save-excursion + (goto-char end) + (if (bolp) + (forward-char -1)) + (buffer-substring start (point)))))) + (t + ;; Interactively, decide whether the warning merits + ;; immediate display. + (or (< (warning-numeric-level level) + (warning-numeric-level warning-minimum-level)) + (warning-suppress-p type warning-suppress-types) + (let ((window (display-buffer buffer))) + (when (and (markerp warning-series) + (eq (marker-buffer warning-series) buffer)) + (set-window-start window warning-series)) + (sit-for 0)))))))) ;;;###autoload (defun lwarn (type level message &rest args) @@ -334,5 +337,4 @@ this is equivalent to `display-warning', using (provide 'warnings) -;; arch-tag: faaad1c8-7b2a-4161-af38-5ab4afde0496 ;;; warnings.el ends here |