diff options
| author | Bill Wohler <wohler@newt.com> | 2014-02-23 18:04:35 -0800 |
|---|---|---|
| committer | Bill Wohler <wohler@newt.com> | 2014-02-23 18:04:35 -0800 |
| commit | 3e93bafb95608467e438ba7f725fd1f020669f8c (patch) | |
| tree | f2f90109f283e06a18caea3cb2a2623abcfb3a92 /lisp/emacs-lisp | |
| parent | 791c0d7634e44bb92ca85af605be84ff2ae08963 (diff) | |
| parent | e918e27fdf331e89268fc2c9d7cf838d3ecf7aa7 (diff) | |
| download | emacs-3e93bafb95608467e438ba7f725fd1f020669f8c.tar.gz | |
Merge from trunk; up to 2014-02-23T23:41:17Z!lekktu@gmail.com.
Diffstat (limited to 'lisp/emacs-lisp')
78 files changed, 7647 insertions, 7033 deletions
diff --git a/lisp/emacs-lisp/.gitignore b/lisp/emacs-lisp/.gitignore deleted file mode 100644 index 133e79e817a..00000000000 --- a/lisp/emacs-lisp/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -!*-loaddefs.el - diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 3d03e894534..0340076720c 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1,9 +1,9 @@ ;;; advice.el --- An overloading mechanism for Emacs Lisp functions -*- lexical-binding: t -*- -;; Copyright (C) 1993-1994, 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 1993-1994, 2000-2014 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Created: 12 Dec 1992 ;; Keywords: extensions, lisp, tools ;; Package: emacs @@ -295,8 +295,8 @@ ;; {<after-K-1-body-form>}* ;; ad-return-value)) -;; Macros and special forms will be redefined as macros, hence the optional -;; [macro] in the beginning of the definition. +;; Macros are redefined as macros, hence the optional [macro] in the +;; beginning of the definition. ;; <arglist> is either the argument list of the original function or the ;; first argument list defined in the list of before/around/after advices. @@ -698,6 +698,7 @@ ;; problems because they get expanded at compile or load time, hence, they ;; might not have all the necessary runtime support and such advice cannot be ;; de/activated or changed as it is possible for functions. +;; ;; Special forms cannot be advised. ;; ;; MORAL: - Only advise macros when you are absolutely sure what you are doing. @@ -1563,29 +1564,6 @@ ;; flexibility and effectiveness of the advice mechanism. Macros that were ;; compile-time expanded before the advice was activated will of course never ;; exhibit the advised behavior. -;; -;; @@ Advising special forms: -;; ========================== -;; Now for something that should be even more rare than advising macros: -;; Advising special forms. Because special forms are irregular in their -;; argument evaluation behavior (e.g., `setq' evaluates the second but not -;; the first argument) they have to be advised into macros. A dangerous -;; consequence of this is that the byte-compiler will not recognize them -;; as special forms anymore (well, in most cases) and use their expansion -;; rather than the proper byte-code. Also, because the original definition -;; of a special form cannot be `funcall'ed, `eval' has to be used instead -;; which is less efficient. -;; -;; MORAL: Do not advise special forms unless you are completely sure about -;; what you are doing (some of the forward advice behavior is -;; implemented via advice of the special forms `defun' and `defmacro'). -;; As a safety measure one should always do `ad-deactivate-all' before -;; one byte-compiles a file to avoid any interference of advised -;; special forms. -;; -;; Apart from the safety concerns advising special forms is not any different -;; from advising plain functions or subrs. - ;;; Code: @@ -2140,14 +2118,6 @@ See Info node `(elisp)Computed Advice' for detailed documentation." "Take a macro function DEFINITION and make a lambda out of it." `(cdr ,definition)) -(defmacro ad-subr-p (definition) - ;;"non-nil if DEFINITION is a subr." - (list 'subrp definition)) - -(defmacro ad-macro-p (definition) - ;;"non-nil if DEFINITION is a macro." - `(eq (car-safe ,definition) 'macro)) - (defmacro ad-lambda-p (definition) ;;"non-nil if DEFINITION is a lambda expression." `(eq (car-safe ,definition) 'lambda)) @@ -2160,12 +2130,12 @@ See Info node `(elisp)Computed Advice' for detailed documentation." (defmacro ad-compiled-p (definition) "Return non-nil if DEFINITION is a compiled byte-code object." `(or (byte-code-function-p ,definition) - (and (ad-macro-p ,definition) - (byte-code-function-p (ad-lambdafy ,definition))))) + (and (macrop ,definition) + (byte-code-function-p (ad-lambdafy ,definition))))) (defmacro ad-compiled-code (compiled-definition) "Return the byte-code object of a COMPILED-DEFINITION." - `(if (ad-macro-p ,compiled-definition) + `(if (macrop ,compiled-definition) (ad-lambdafy ,compiled-definition) ,compiled-definition)) @@ -2173,7 +2143,7 @@ See Info node `(elisp)Computed Advice' for detailed documentation." "Return the lambda expression of a function/macro/advice DEFINITION." (cond ((ad-lambda-p definition) definition) - ((ad-macro-p definition) + ((macrop definition) (ad-lambdafy definition)) ((ad-advice-p definition) (cdr definition)) @@ -2183,7 +2153,7 @@ See Info node `(elisp)Computed Advice' for detailed documentation." "Return the argument list of DEFINITION." (require 'help-fns) (help-function-arglist - (if (or (ad-macro-p definition) (ad-advice-p definition)) + (if (or (macrop definition) (ad-advice-p definition)) (cdr definition) definition) 'preserve-names)) @@ -2215,26 +2185,6 @@ Like `interactive-form', but also works on pieces of advice." (if (ad-interactive-form definition) 1 0)) (cdr (cdr (ad-lambda-expression definition))))))) -(defun ad-make-advised-definition-docstring (_function) - "Make an identifying docstring for the advised definition of FUNCTION. -Put function name into the documentation string so we can infer -the name of the advised function from the docstring. This is needed -to generate a proper advised docstring even if we are just given a -definition (see the code for `documentation')." - (eval-when-compile - (propertize "Advice function assembled by advice.el." - 'dynamic-docstring-function - #'ad--make-advised-docstring))) - -(defun ad-advised-definition-p (definition) - "Return non-nil if DEFINITION was generated from advice information." - (if (or (ad-lambda-p definition) - (ad-macro-p definition) - (ad-compiled-p definition)) - (let ((docstring (ad-docstring definition))) - (and (stringp docstring) - (get-text-property 0 'dynamic-docstring-function docstring))))) - (defun ad-definition-type (definition) "Return symbol that describes the type of DEFINITION." ;; These symbols are only ever used to check a cache entry's validity. @@ -2242,8 +2192,8 @@ definition (see the code for `documentation')." ;; representations, so cache entries preactivated with version ;; 1 can't be used. (cond - ((ad-macro-p definition) 'macro2) - ((ad-subr-p definition) 'subr2) + ((macrop definition) 'macro2) + ((subrp definition) 'subr2) ((or (ad-lambda-p definition) (ad-compiled-p definition)) 'fun2) ((ad-advice-p definition) 'advice2))) ;; FIXME: Can this ever happen? @@ -2273,14 +2223,13 @@ For that it has to be fbound with a non-autoload definition." "True if FUNCTION has an interpreted definition that can be compiled." (and (ad-has-proper-definition function) (or (ad-lambda-p (symbol-function function)) - (ad-macro-p (symbol-function function))) + (macrop (symbol-function function))) (not (ad-compiled-p (symbol-function function))))) (defvar warning-suppress-types) ;From warnings.el. (defun ad-compile-function (function) "Byte-compile the assembled advice function." (require 'bytecomp) - (require 'warnings) ;To define warning-suppress-types before we let-bind it. (let ((byte-compile-warnings byte-compile-warnings) ;; Don't pop up windows showing byte-compiler warnings. (warning-suppress-types '((bytecomp)))) @@ -2529,36 +2478,39 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return (require 'help-fns) ;For help-split-fundoc and help-add-fundoc-usage. -(defun ad--make-advised-docstring (origdoc function &optional style) +(defun ad--make-advised-docstring (function &optional style) "Construct a documentation string for the advised FUNCTION. -It concatenates the original documentation with the documentation -strings of the individual pieces of advice which will be formatted -according to STYLE. STYLE can be `plain', everything else -will be interpreted as `default'. The order of the advice documentation -strings corresponds to before/around/after and the individual ordering -in any of these classes." - (if (and (symbolp function) - (string-match "\\`ad-+Advice-" (symbol-name function))) - (setq function - (intern (substring (symbol-name function) (match-end 0))))) - (let* ((usage (help-split-fundoc origdoc function)) - paragraphs advice-docstring) - (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage))) - (if origdoc (setq paragraphs (list origdoc))) - (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 - (push advice-docstring paragraphs)))) - (setq origdoc (if paragraphs - (propertize - ;; separate paragraphs with blank lines: - (mapconcat 'identity (nreverse paragraphs) "\n\n") - ;; FIXME: what is this for? - 'dynamic-docstring-function - #'ad--make-advised-docstring))) - (help-add-fundoc-usage origdoc usage))) +Concatenate the original documentation with the documentation +strings of the individual pieces of advice. Optional argument +STYLE specifies how to format the pieces of advice; it can be +`plain', or any other value which means the default formatting. + +The advice documentation is shown in order of before/around/after +advice type, obeying the priority in each of these types." + ;; Retrieve the original function documentation + (let* ((fun (get function 'function-documentation)) + (origdoc (unwind-protect + (progn (put function 'function-documentation nil) + (documentation function t)) + (put function 'function-documentation fun)))) + (if (and (symbolp function) + (string-match "\\`ad-+Advice-" (symbol-name function))) + (setq function + (intern (substring (symbol-name function) (match-end 0))))) + (let* ((usage (help-split-fundoc origdoc function)) + paragraphs advice-docstring) + (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage))) + (if origdoc (setq paragraphs (list origdoc))) + (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 + (push advice-docstring paragraphs)))) + (setq origdoc (if paragraphs + (mapconcat 'identity (nreverse paragraphs) + "\n\n"))) + (help-add-fundoc-usage origdoc usage)))) ;; @@@ Accessing overriding arglists and interactive forms: @@ -2606,7 +2558,7 @@ in any of these classes." ;; Finally, build the sucker: (ad-assemble-advised-definition advised-arglist - (ad-make-advised-definition-docstring function) + nil interactive-form orig-form (ad-get-enabled-advices function 'before) @@ -2903,7 +2855,7 @@ If COMPILE is nil then the result depends on the value of ((eq ad-default-compilation-action 'never) nil) ((eq ad-default-compilation-action 'always) t) ((eq ad-default-compilation-action 'like-original) - (or (ad-subr-p (ad-get-orig-definition function)) + (or (subrp (ad-get-orig-definition function)) (ad-compiled-p (ad-get-orig-definition function)))) ;; everything else means `maybe': (t (featurep 'byte-compile)))) @@ -2920,6 +2872,8 @@ The current definition and its cache-id will be put into the cache." (fset advicefunname (or verified-cached-definition (ad-make-advised-definition function))) + (put advicefunname 'function-documentation + `(ad--make-advised-docstring ',advicefunname)) (unless (equal (interactive-form advicefunname) old-ispec) ;; If the interactive-spec of advicefunname has changed, force nadvice to ;; refresh its copy. @@ -3199,7 +3153,7 @@ 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) (indent 2) (debug (&define name ;; thing being advised. (name ;; class is [&or "before" "around" "after" ;; "activation" "deactivation"] @@ -3250,7 +3204,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) `((ad-set-cache ',function ;; the function will get compiled: - ,(cond ((ad-macro-p (car preactivation)) + ,(cond ((macrop (car preactivation)) `(ad-macrofy (function ,(ad-lambdafy diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 270badd53cb..dfc60512c61 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -1,6 +1,6 @@ ;;; authors.el --- utility for maintaining Emacs's AUTHORS file -*-coding: utf-8 -*- -;; Copyright (C) 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 2000-2014 Free Software Foundation, Inc. ;; Author: Gerd Moellmann <gerd@gnu.org> ;; Maintainer: Kim F. Storm <storm@cua.dk> @@ -51,50 +51,36 @@ files.") ("Bill Rozas" "Guillermo J. Rozas") ("Björn Torkelsson" "Bjorn Torkelsson") ("Brian Fox" "Brian J. Fox") + ("Brian P Templeton" "BT Templeton") ("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 J. Biesack" "David Biesack") ("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. Koppelman" "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" - "Reingold Edward M") - ("Eli Zaretskii" "eliz") + ("Edward M. Reingold" "Ed\\(ward\\( M\\)?\\)? Reingold" "Reingold Edward M") ("Emilio C. Lopes" "Emilio Lopes") - ("Era Eriksson" "Era@Iki.Fi") ("Eric M. Ludlam" "Eric Ludlam") ("Eric S. Raymond" "Eric Raymond") - ("Eric Youngdale" "(Eric Youngdale at youngdale@v6550c.nrl.navy.mil)") + ("Fabián Ezequiel Gallina" "Fabian Ezequiel Gallina" "Fabi.n E\\. Gallina") ("Francis J. Wright" "Dr Francis J. Wright" "Francis Wright") ("François Pinard" "Francois Pinard") ("Francesco Potortì" "Francesco Potorti" "Francesco Potorti`") ("Frederic Pierresteguy" "Fred Pierresteguy") - ("Geoff Voelker" "voelker") ("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. - ;; http://quimby.gnus.org/cgi-bin/cvsweb.cgi/gnus/lisp/gnus-art.el?rev=4.13 - (nil "<Use-Author-Address-Header@\\[127.1\\]>") (nil "Code Extracted") ; lisp/newcomment.el's "Author:" header - (nil "\\`FSF") ; FIXME what is this for - no effect? - ;; lisp/gnus/ChangeLog.1, 1997-10-12, since fixed. -;;; (nil "ISO-2022-JP") ("Jaeyoun Chung" "Jae-youn Chung" "Jae-you Chung" "Chung Jae-youn") ("Jan Djärv" "Jan D." "Jan Djarv") - ("Jay K. Adams" "jka@ece.cmu.edu" "Jay Adams") + ("Jay K. Adams" "Jay Adams") ("Jérôme Marant" "Jérôme Marant" "Jerome Marant") ("Jens-Ulrik Holger Petersen" "Jens-Ulrik Petersen") ("Jeremy Bertram Maitin-Shepard" "Jeremy Maitin-Shepard") @@ -102,24 +88,24 @@ files.") ("John J Foerch" "John Foerch") ("John W. Eaton" "John Eaton") ("Jonathan I. Kamens" "Jonathan Kamens") + ("Jorgen Schäfer" "Jorgen Schaefer") ("Joseph Arceneaux" "Joe Arceneaux") ("Joseph M. Kelsey" "Joe Kelsey") ; FIXME ? ("Juan León Lahoz GarcÃa" "Juan-Leon Lahoz Garcia") ("K. Shane Hartman" "Shane Hartman") - ("Kai Großjohann" "Kai Grossjohann" "Kai Großjohann" - "Kai.Grossjohann@Cs.Uni-Dortmund.De" - "Kai.Grossjohann@Gmx.Net") + ("Kai Großjohann" "Kai Grossjohann") ("Karl Berry" "K. Berry") ("Károly LÅ‘rentey" "Károly LÅ‘rentey" "LÅ‘rentey Károly") - ("Kazushi Marukawa" "Kazushi") + ("Kazushi Marukawa" "Kazushi (Jam) Marukawa") ("Ken Manheimer" "Kenneth Manheimer") - ("Kenichi Handa" "Ken'ichi Handa" "Kenichi HANDA") + ("Kenichi Handa" "Ken'ichi Handa" "Kenichi HANDA" "K\\. Handa") ("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") + ("Mark E. Shoulson" "Mark Shoulson") ("Marko Kohtala" "Kohtala Marko") ("AgustÃn MartÃn" "Agustin Martin" "AgustÃn MartÃn Domingo") ("Martin Lorentzon" "Martin Lorentzson") @@ -128,37 +114,36 @@ files.") ("Michael R. Mauger" "Michael Mauger") ("Michael D. Ernst" "Michael Ernst") ("Michaël Cadilhac" "Michael Cadilhac") - ("Michael I. Bushnell" "Michael I Bushnell" "Michael I. Bushnell, P/Bsg") + ("Michael I. Bushnell" "Michael I Bushnell" "Michael I. Bushnell, p/BSG") ("Michael R. Cook" "Michael Cook") ("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") + ("Paul Eggert" "Paul R\\. Eggert") + ("Pavel JanÃk" "Pavel JanÃk Ml." "Pavel Janik Ml." "Pavel Janik") ("Pavel Kobiakov" "Pavel Kobyakov") ("Per Abrahamsen" "Per Abhiddenware") ("Per Starbäck" "Per Starback") ("Peter J. Weisberg" "PJ Weisberg") - ("Peter S. Galbraith" "Peter Galbraith") + ("Peter S. Galbraith" "Peter S Galbraith" "Peter Galbraith") ("Peter Runestig" "Peter 'luna' Runestig") - ("Peter S. Galbraith" "Peter S Galbraith") + ("Piotr ZieliÅ„ski" "Piotr Zielinski") + ("Rainer Schöpf" "Rainer Schoepf") ("Raja R. Harinath" "Raja R Harinath") ("Richard G. Bielawski" "Richard G Bielawski" "Richard Bielawski") ("Richard King" "Dick King") - ("Richard M. Stallman" "Richard M. Stallman,,," "Richard Stallman" - "rms" "rms@gnu.org") + ("Richard M. Stallman" "Richard Stallman" "rms@gnu.org") ("Robert J. Chassell" "Bob Chassell") + ("Roberto Huelga DÃaz" "Roberto Huelga") ("Roland B. Roberts" "Roland B Roberts" "Roland Roberts") - ("Rui-Tao Dong" "Rui-Tao Dong ~{6-Hpln~}") + ("Rui-Tao Dong" "Rui-Tao Dong ~{6-HpLN~}") ("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") @@ -174,7 +159,7 @@ files.") ("Tomohiko Morioka" "MORIOKA Tomohiko") ("Torbjörn Axelsson" "Torbjvrn Axelsson") ("Torbjörn Einarsson" "Torbj.*rn Einarsson") - ("Toru Tomabechi" "Toru Tomabechi,") + ("Toru Tomabechi" "Toru TOMABECHI") ("Tsugutomo Enami" "enami tsugutomo") ("Ulrich Müller" "Ulrich Mueller") ("Vincent Del Vecchio" "Vince Del Vecchio") @@ -192,7 +177,8 @@ 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" + '("Brian van den Broek" + "Bryan O'Sullivan" "Christian von Roques" "Christophe de Dinechin" "Craig McDaniel" @@ -206,7 +192,9 @@ If REALNAME is nil, ignore that author.") "Greg McGary" "Hans de Graaff" "James TD Smith" + "Jay McCarthy" "Joel N. Weber II" + "Matt McClure" "Michael McNamara" "Mike McEwan" "Nelson Jose dos Santos Ferreira" @@ -216,6 +204,7 @@ If REALNAME is nil, ignore that author.") "Roland McGrath" "Sean O'Halpin" "Sean O'Rourke" + "Thomas DeWeese" "Tijs van Bakel") "List of authors whose names cannot be simply capitalized.") @@ -238,15 +227,15 @@ If REALNAME is nil, ignore that author.") (defvar authors-obsolete-files-regexps - '("vc-\\*\\.el$" - "spec.txt$" - ".*loaddefs.el$" ; not obsolete, but auto-generated + '(".*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" + "build-aux/" "m4/" "Emacs.xcodeproj" "mapfiles" "\\.map\\'" "preferences\\.\\(nib\\|gorm\\)" - "vc-\\(rcs\\|cvs\\|sccs\\)-hooks\\.el$") + ;; Generated files that have since been removed. + "\\(refcard\\(-de\\|-pl\\)?\\|calccard\\|dired-ref\\|orgcard\\|\ +gnus-booklet\\|fr-drdref\\)\\.p\\(df\\|s\\)\\'") "List of regexps matching obsolete files. Changes to files matching one of the regexps in this list are not listed.") @@ -261,14 +250,19 @@ Changes to files matching one of the regexps in this list are not listed.") "NEWS.1" "OOOOONEWS...OONEWS" "OOOONEWS" "etc/NEWS" "NEWS.1-17" "NEWS.18" "NEWS.19" "NEWS.20" "NEWS.21" "NEWS.22" "MAINTAINERS" "MH-E-NEWS" - "install-sh" "missing" "mkinstalldirs" + "install.sh" "install-sh" "missing" "mkinstalldirs" "termcap.dat" "termcap.src" "termcap.ucb" "termcap" "ChangeLog.nextstep" "Emacs.clr" "spec.txt" "gfdl.1" "texi/Makefile.in" "Imakefile" "icons/sink.ico" "aixcc.lex" "nxml/char-name/unicode" + "spec.txt" "js2-mode.el" ; only installed very briefly, replaced by js.el + ;; In the old imported lisp/url ChangeLog, but never in Emacs. + "mule-sysdp.el" + ;; Only briefly present. + "tests/gnustest-nntp.el" "tests/gnustest-registry.el" "cedet/tests/testtemplates.cpp" "cedet/tests/testusing.cpp" "cedet/tests/scopetest.cpp" @@ -278,8 +272,13 @@ Changes to files matching one of the regexps in this list are not listed.") "cedet/tests/teststruct.cpp" "*.el" ;; Autogen: - "cus-load.el" "finder-inf.el" "ldefs-boot.el" + "cus-load.el" "finder-inf.el" "ldefs-boot.el" "loaddefs-boot.el" "compile" "config.guess" "config.sub" "depcomp" + "autogen/compile" "autogen/config.guess" "autogen/config.in" + "autogen/config.sub" "autogen/depcomp" "autogen/install-sh" + "autogen/missing" "autogen" + "autogen/copy_autogen" ; not generated, but trivial and now removed + "dir_top" ;; Only existed briefly, then renamed: "images/icons/allout-widgets-dark-bg" "images/icons/allout-widgets-light-bg" @@ -289,10 +288,12 @@ Changes to files matching one of the regexps in this list are not listed.") "gnu-hp300" "refcard.bit" "ledit.l" "forms.README" "forms-d2.dat" "CXTERM-DIC/PY.tit" "CXTERM-DIC/ZIRANMA.tit" "CXTERM-DIC/CTLau.tit" "CXTERM-DIC/CTLauB.tit" + "copying.paper" "celibacy.1" "condom.1" "echo.msg" "sex.6" + "COOKIES" "INTERVIEW" "MAILINGLISTS" "MOTIVATION" "NICKLES.WORTH" "INTERVAL.IDEAS" "RCP" "3B-MAXMEM" "AIX.DUMP" "SUN-SUPPORT" "XENIX" "CODINGS" "CHARSETS" - "calc/INSTALL" "calc/Makefile" + "calc/INSTALL" "calc/Makefile" "calc/README.prev" "vms-pp.trans" "_emacs" "batcomp.com" "notes/cpp" ; admin/ "emacsver.texi.in" "vpath.sed" @@ -329,16 +330,23 @@ Changes to files matching one of the regexps in this list are not listed.") "debian/scripts/startup" "debian/scripts/startup.erc" "debian/scripts/startup.erc-speak" + ;; Used to be in admin, not very interesting. + "emacs-pretesters" "make-announcement" "make-changelog-diff" + ;; Textual comments that are not files. + "All" "Version" "Everywhere" "Many" "Various" "files" + ;; Directories. + "vms" "mac" "url" "tree-widget" ) "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" + '("Makefile.in" + "makefile.w32-in" + "chart.el" + "cl-lib.el" "compile.el" "complete.el" "cpp.el" @@ -357,11 +365,13 @@ Changes to files in this list are not listed.") "format.el" "generic.el" "georgian.el" + "grammar.el" "greek.el" "grep.el" "hebrew.el" "imenu.el" "indian.el" + "info-xref.el" "japanese.el" "java.el" "lao.el" @@ -369,6 +379,7 @@ Changes to files in this list are not listed.") "locate.el" "make.el" "mode.el" + "mule-util.el" "python.el" "rmailmm.el" "semantic.el" @@ -381,6 +392,7 @@ Changes to files in this list are not listed.") "table.el" "texi.el" "thai.el" + "thingatpt.el" "tibetan.el" "util.el" "vc-bzr.el" @@ -399,11 +411,15 @@ Changes to files in this list are not listed.") ("David M. Brown" :wrote "array.el") ;; No longer distributed. ;;; ("Gary Byers" :changed "xenix.h") - ("Shawn M. Carey" :wrote "freebsd.h") + ;; No longer distributed: freebsd.h + ;; Only trivial pieces remain, merged into configure.ac. + ("Shawn M. Carey" :wrote "[some early FreeBSD support]") ;; hp800.h renamed from hp9000s800.h, hpux.h merged into hpux10-20.h. ;; FIXME overwritten by Author:. ("Satyaki Das" :cowrote "mh-search.el") - ("Eric Decker" :changed "hp800.h" "hpux10-20.h" "sysdep.c") + ;; No longer distributed: hp800.h, hpux10-20.h. + ;; Only trivial pieces remain, merged into configure.ac. + ("Eric Decker" :changed "sysdep.c (and other files for HP-UX support)") ("Lawrence R. Dodd" :cowrote "dired-x.el") ;; No longer distributed. ;;; ("Viktor Dukhovni" :wrote "unexsunos4.c") @@ -434,15 +450,16 @@ Changes to files in this list are not listed.") "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.ac" "emacs.c" "intel386.h" - "mem-limits.h" "process.c" "template.h" "sysdep.c" "syssignal.h" - "systty.h" "unexcoff.c" "linux.h") + ;; No longer distributed: ymakefile, intel386.h, mem-limits.h, template.h, + ;; linux.h (was renamed to lignux.h, then to gnu-linux.h, then removed) + ("Michael K. Johnson" :changed "configure.ac" "emacs.c" + "process.c" "sysdep.c" "syssignal.h" "systty.h" "unexcoff.c") ;; No longer distributed. ;;; ("Kyle Jones" :wrote "mldrag.el") ("Henry Kautz" :wrote "bib-mode.el") - ;; No longer distributed: vms-pwd.h, vmsfns.c, uaf.h. - ("Joseph M. Kelsey" :changed "fileio.c" "dir.h") + ;; No longer distributed: vms-pwd.h, vmsfns.c, uaf.h, + ;; dir.h (was renamed to vmsdir.h, then removed) + ("Joseph M. Kelsey" :changed "fileio.c") ("Sam Kendall" :changed "etags.c" "etags.el") ;; ack.texi: "We're not using his backquote.el any more." ("Richard King" :wrote "userlock.el" "filelock.c") @@ -481,11 +498,12 @@ Changes to files in this list are not listed.") ("Mark Neale" :changed "fortran.el") ;; Renamed from sc.el. ("Martin Neitzel" :changed "supercite.el") - ("Andrew Oram" :changed "calendar.texi (and other files in man/)") + ("Andrew Oram" :changed "calendar.texi (and other doc files)") ("Frederic Pierresteguy" :wrote "widget.c") ("Michael D. Prange" :changed "tex-mode.el") ;; No longer distributed (dgux5-4r3.h was renamed to dgux5-4-3.h). ;;; ("Paul Reilly" :wrote "gux5-4r2.h" "dgux5-4-3.h") + ("Rob Riepel" :wrote "tpu-edt.doc") ("Roland B. Roberts" :changed "files.el" "sort.el" "buffer.h" "callproc.c" "dired.c" "process.c" "sysdep.c" "systty.h") ;; No longer distributed. @@ -494,14 +512,16 @@ Changes to files in this list are not listed.") ;;; ("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. - "config.in" "ecrt0.c" "data.c" "fns.c" + ;; config.in renamed from config.h.in, now a generated file. + ;; ecrt0.c renamed from crt0.c, then removed. + "data.c" "fns.c" "lisp.h" "lread.c" ; "sun3.h" "ymakefile" - no longer distributed "print.c" :wrote "float-sup.el" "floatfns.c") ("Schlumberger Technology Corporation" :changed "gud.el") ;; Replaced by tcl.el. ;;; ("Gregor Schmid" :wrote "tcl-mode.el") - ("Rainer Schoepf" :wrote "alpha.h" "unexalpha.c") + ;; No longer distributed since 24.1. +;;; ("Rainer Schöpf" :wrote "alpha.h" "unexalpha.c") ;; No longer distributed: emacsserver.c. ("William Sommerfeld" :wrote "emacsclient.c" "scribe.el") ;; No longer distributed: emacsserver.c. @@ -520,7 +540,8 @@ Changes to files in this list are not listed.") ("Spencer Thomas" :changed "emacsclient.c" "server.el" "dabbrev.el" "unexcoff.c" "gnus.texi") ("Jonathan Vail" :changed "vc.el") - ("James Van Artsdalen" :changed "usg5-4.h" "unexcoff.c") + ;; No longer distributed: usg5-4.h + ("James Van Artsdalen" :changed "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; @@ -529,7 +550,8 @@ 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]") + ("Eli Zaretskii" :wrote "bidi.c" "[bidirectional display in xdisp.c]" + "[tty menus in term.c]") ;; Not using this version any more. ;;; ("Pace Willisson" :wrote "ispell.el") ;; FIXME overwritten by Author:. @@ -544,16 +566,24 @@ Changes to files in this list are not listed.") (defconst authors-valid-file-names '("aclocal.m4" "build-ins.in" + "Makefile" "Makefile.noleim" "makedist.bat" "makefile.def" "makefile.nt" "ns.mk" + "README" + ;; There were a few of these, not just the generated top-level one. + "configure" "config.h" + ;; nt/ + "ebuild.bat" "install.bat" "fast-install.bat" "debug.bat.in" "emacs.bat.in" + "inc/sys/dir.h" "inc/gettext.h" ".gdbinit-union" "alloca.s" "make-delta" "config.w95" + "msysconfig.sh" "emacstool.1" "align.umax" "cxux-crt0.s" @@ -571,16 +601,85 @@ Changes to files in this list are not listed.") "emacs16_mac.png" "emacs24_mac.png" "emacs256_mac.png" "emacs32_mac.png" "emacs48_mac.png" "emacs512_mac.png" + "ps-prin2.ps" "ps-prin3.ps" + "emacs.xbm" "gnu.xpm" "gnus-pointer.xbm" "gnus-pointer.xpm" + ;; Moved from etc/ to etc/images, and/or removed. + "gnus.pbm" "gnus.xbm" "gnus.xpm" "letter.pbm" "letter.xbm" "letter.xpm" + "splash.pbm" "splash.xbm" "splash.xpm" "splash8.xpm" + "images/execute.pbm" "images/execute.xpm" "images/fld-open.pbm" + "images/fld-open.xpm" "images/highlight.pbm" "images/highlight.xpm" + "images/mail.pbm" "images/mail.xpm" "images/mail/alias.pbm" + "images/mail/alias.xpm" "images/mail/refile.pbm" + "images/mail/refile.xpm" "images/page-down.pbm" + "images/page-down.xpm" "images/widen.pbm" "images/widen.xpm" + "images/gnus/bar.xbm" "images/gnus/bar.xpm" + "images/gnus/reverse-smile.xpm" "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" + "compact.el" "fadr.el" + "calc/calc-maint.el" + "emacs-lisp/eieio-comp.el" + "erc-hecomplete.el" + "eshell/esh-maint.el" + "language/persian.el" + "meese.el" "iswitchb.el" + "mh-exec.el" "mh-init.el" "mh-customize.el" + "net/zone-mode.el" "xesam.el" + "term/mac-win.el" "sup-mouse.el" + "url-https.el" + "org-mac-message.el" "org-mew.el" "org-w3m.el" "org-vm.el" "org-wl.el" + "org-mks.el" "org-remember.el" "org-xoxo.el" "org-docbook.el" + "org-freemind.el" "ox-jsinfo.el" + "org-exp-blocks.el" ; maybe this is ob-exp now? dunno + "org-lparse.el" + "org-special-blocks.el" "org-taskjuggler.el" + ;; gnus + "nnwfm.el" "nnlistserv.el" "nnkiboze.el" "nndb.el" "nnsoup.el" + "netrc.el" "password.el" "sasl-cram.el" "sasl-digest.el" "sasl-ntlm.el" + "sasl.el" "dig.el" "dns.el" "hex-util.el" "sha1.el" "md4.el" + "hmac-def.el" "hmac-md5.el" "ntlm.el" "hashcash.el" "smime-ldap.el" + "assistant.el" "gnus-utils.el" "tls.el" "pgg-def.el" "pgg-gpg.el" + "gnus-compat.el" "pgg-parse.el" "pgg-pgp.el" "pgg-pgp5.el" "pgg.el" + "dns-mode.el" "run-at-time.el" "gnus-encrypt.el" "sha1-el.el" + "gnus-gl.el" "gnus.sum.el" "proto-stream.el" "color.el" "color-lab.el" + "eww.el" "shr-color.el" "shr.el" "earcon.el" "gnus-audio.el" "encrypt.el" + ;; doc + "getopt.c" "texindex.c" "news.texi" "vc.texi" "vc2-xtra.texi" + "back.texi" "vol1.texi" "vol2.texi" "elisp-covers.texi" "two.el" + "front-cover-1.texi" "locals.texi" "calendar.texi" "info-stnd.texi" + "tasks.texi" + "advice.texi" "picture.texi" "texinfo.tex" + ;; lwlib: + "dispatch.c" "dispatch.h" "xrdb-cpp.c" "xrdb.c" + "lwlib-Xol.c" "lwlib-Xol.h" "lwlib-Xolmb.c" "lwlib-Xolmb.h" + "lwlib-XolmbP.h" + ;; lib/ + "lib/stdio.c" "lib/gl_openssl.h" "lib/sigprocmask.c" + "lib/pthread_sigprocmask.c" "lib/ldtoastr.c" "lib/dummy.c" + "lib/ignore-value.h" + ;; lib-src/ + "cvtmail.c" "digest-doc.c" "emacsserver.c" "emacstool.c" "env.c" + "etags-vmslib.c" "fakemail.c" "getdate.c" "getopt.h" "getopt1.c" + "getopt_.h" "getopt_int.h" "gettext.h" "leditcfns.c" "loadst.c" + "make-path.c" "qsort.c" "sorted-doc.c" "tcp.c" "timer.c" "wakeup.c" + "yow.c" + ;; etc/ + "emacsclient.c" "etags.c" "hexl.c" "make-docfile.c" "movemail.c" + "test-distrib.c" "testfile" + "tpu-edt.doc" ; see below ) "File names which are valid, but no longer exist (or cannot be found) in the repository.") +;; Note that any directory part on the RHS is retained. +;; Cf authors-renamed-files-regexps. +;; NB So only add a directory if needed to disambiguate. +;; FIXME? +;; Although perhaps we could let authors-disambiguate-file-name do that? (defconst authors-renamed-files-alist '(("nt.c" . "w32.c") ("nt.h" . "w32.h") ("ntheap.c" . "w32heap.c") ("ntheap.h" . "w32heap.h") @@ -590,15 +689,29 @@ in the repository.") ("unexnt.c" . "unexw32.c") ("s/windowsnt.h" . "s/ms-w32.h") ("s/ms-w32.h" . "inc/ms-w32.h") + ("src/config.h" . "config.h") ("winnt.el" . "w32-fns.el") + ("linux.h" . "gnu-linux.h") ("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") - ("paths.h-dist" . "paths.h.in") + ("debug.bat" . "debug.bat.in") + ("emacs.bat" . "emacs.bat.in") + ;; paths.h.dist -> paths.h-dist -> paths.h.in -> paths.in -> epaths.in. + ("paths.h.dist" . "epaths.in") + ("paths.h-dist" . "epaths.in") + ("paths.h.in" . "epaths.in") + ("paths.in" . "epaths.in") ("patch1" . "sed1.inp") + ("INSTALL.MSYS" . "INSTALL") + ("server.c" . "emacsserver.c") + ("lib-src/etags.c" . "etags.c") + ;; msdos/ + ("is-exec.c" . "is_exec.c") + ("enriched.doc" . "enriched.txt") ("GETTING.GNU.SOFTWARE" . "FTP") ("etc/MACHINES" . "MACHINES") ("ONEWS" . "NEWS.19") @@ -611,42 +724,85 @@ in the repository.") ("DIFF" . "OTHER.EMACSES") ("CCADIFF" . "OTHER.EMACSES") ("GOSDIFF" . "OTHER.EMACSES") + ;; Moved from lisp/tpu-doc.el to etc/tpu-edt.doc in Emacs 19.29. + ;; Removed in Emacs 19.30, replaced by new file etc/edt-user.doc + ;; (no associated ChangeLog entry). + ("tpu-doc.el" . "tpu-edt.doc") ("Makefile.in.in" . "Makefile.in") ("leim-Makefile" . "leim/Makefile") ("leim-Makefile.in" . "leim/Makefile.in") ("emacs-lisp/testcover-ses.el" . "tcover-ses.el") ("emacs-lisp/testcover-unsafep.el" . "tcover-unsafep.el") + ("progmodes/dos.el" . "bat-mode.el") ;; 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") - ("refcards/fr-drdref.pdf" . "refcards/fr-dired-ref.pdf") - ("gnus-logo.eps" . "refcards/gnus-logo.eps") + ("help-funs.el" . "help-fns.el") + ("erc-notifications.el" . "erc-desktop-notifications.el") + ("org-complete.el" . "org-pcomplete.el") + ("org-export.el" . "ox.el") ; ? + ;; Was definitely renamed to org-latex.el, then... ? + ("org-export-latex.el" . "ox-latex.el") ; ? + ("org-exp.el" . "ox.el") ; ? + ("progmodes/cfengine3.el" . "cfengine.el") + ("progmodes/delphi.el" . "opascal.el") + ("octave-inf.el" . "octave.el") + ("octave-mod.el" . "octave.el") + ("progmodes/octave-inf.el" . "octave.el") + ("progmodes/octave-mod.el" . "octave.el") + ;; Obsolete. + ("play/bruce.el" . "bruce.el") + ("patcomp.el" . "patcomp.el") + ;; From lisp to etc/forms. + ("forms-d2.el" . "forms-d2.el") + ("forms-pass.el" . "forms-pass.el") + ;; From lisp/ to etc/nxml. + ("nxml/test.invalid.xml" . "test-invalid.xml") + ("nxml/test.valid.xml" . "test-valid.xml") + ;; The one in lisp is eshell/eshell.el. + ("eshell.el" . "automated/eshell.el") + ("eshell/esh-test.el" . "automated/eshell.el") + ;; INSTALL-CVS -> .CVS -> .BZR -> .REPO + ("INSTALL-CVS" . "INSTALL.REPO") + ("INSTALL.CVS" . "INSTALL.REPO") + ("INSTALL.BZR" . "INSTALL.REPO") + ("gnus-logo.eps" . "gnus-logo.eps") ; moved to refcards/ ("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") + ;; Moved from top to etc/ + ("CONTRIBUTE" . "CONTRIBUTE") + ("FTP" . "FTP") + ;; Moved from top to build-aux/ + ("move-if-change" . "move-if-change") + ("update-subdirs" . "update-subdirs") + ("emacs.tex" . "emacs.texi") + ("faq.texi" . "efaq.texi") + ("major.texi" . "modes.texi") + ;; And from emacs/ to misc/ and back again. + ("ns-emacs.texi" . "macos.texi") + ("overrides.texi" . "gnus-overrides.texi") + ("xresmini.texi" . "xresources.texi") ;; Not renamed, but we only have the latter in the Emacs repo. ("trampver.texi.in" . "trampver.texi") - ("e/eterm" . "e/eterm-color") - ("e/eterm.ti" . "e/eterm-color.ti") + ;; Renamed with same directory. + ("e/eterm" . "eterm-color") + ("e/eterm.ti" . "eterm-color.ti") ("README.txt" . "README") ("emacs.names" . "JOKES") ("ED.WORSHIP" . "JOKES") ("GNU.JOKES" . "JOKES") ("CHARACTERS" . "TODO") - ("schema/xhtml-basic-form.rnc" . "schema/xhtml-bform.rnc" ) - ("schema/xhtml-basic-table.rnc" . "schema/xhtml-btable.rnc") - ("schema/xhtml-list.rnc" . "schema/xhtml-lst.rnc") - ("schema/xhtml-target.rnc" . "schema/xhtml-tgt.rnc") - ("schema/xhtml-style.rnc" . "schema/xhtml-xstyle.rnc") - ("schema/docbook-dyntbl.rnc" . "schema/docbk-dyntbl.rnc") - ("schema/docbook-soextbl.rnc" . "schema/docbk-soextbl.rn" ) - ("texi/url.txi" . "url.texi") + ("images/gnus/mail_send.xpm" . "mail-send.xpm") ; still in images/gnus + ;; Renamed within same directory. + ("schema/xhtml-basic-form.rnc" . "xhtml-bform.rnc" ) + ("schema/xhtml-basic-table.rnc" . "xhtml-btable.rnc") + ("schema/xhtml-list.rnc" . "xhtml-lst.rnc") + ("schema/xhtml-target.rnc" . "xhtml-tgt.rnc") + ("schema/xhtml-style.rnc" . "xhtml-xstyle.rnc") + ("schema/docbook-dyntbl.rnc" . "docbk-dyntbl.rnc") + ("schema/docbook-soextbl.rnc" . "docbk-soextbl.rn" ) ("edt-user.doc" . "edt.texi") ("DEV-NOTES" . "nextstep") ("org/COPYRIGHT-AND-LICENSE" . "org/README") @@ -656,61 +812,164 @@ in the repository.") ("emacs.1" . "emacs.1") ("emacsclient.1" . "emacsclient.1") ("icons/emacs21.ico" . "emacs21.ico") + ("ja-dic" . "leim/ja-dic") + ("quail" . "leim/quail") + ;; Moved from autogen/ to admin/. + ("autogen/update_autogen" . "update_autogen") + ;; Moved from etc/ to admin/. + ("grammars" . "grammars") + ;; From etc to lisp/cedet/semantic/. + ("grammars/bovine-grammar.el" . "bovine/grammar.el") + ("grammars/wisent-grammar.el" . "wisent/grammar.el") ;; 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).") +;; Should still test that the renamed file exists. Does it? +;; But it might be relative to a different ChangeLog... +;; +;; Note that only the basename of the RHS is used. +;; Cf authors-renamed-files-alist. (defconst authors-renamed-files-regexps - '(("^m/m-\\(.*\\.h\\)$" . "m/\\1") - ("^m-\\(.*\\.h\\)$" . "\\1") - ("^s/s-\\(.*\\.h\\)$" . "s/\\1") - ("^s-\\(.*\\.h\\)$" . "\\1") - ("^s/[-.a-zA-Z0-9_]+\\.h$" . t) - ("\\(.*\\)\\.cmd$" . "\\1.bat") - ("\\.bat$" . t) - ("\\.[ch]$" . t) - ("\\.el$" . t) - ("\\.ps$" . t) - ("\\.texi?$" . t) - ("\\.texinfo$" . t) - ("\\.xml?$" . t) - ("\\.x[pb]m$" . t) - ("\\.[xp]bm$" . t) - ("^paths\\." . t) - ("^install\\." . t) - ("^\\(TUTORIAL[^/]*\\)" . "tutorials/\\1") - ("^\\(tree-widget/\\(?:default\\|folder\\)/[-a-z]+\\.png\\)$" . + '(("\\`\\(arg-nonnull\\|c\\+\\+defs\\|warn-on-use\\)\\.h\\'" + "build-aux/snippet/\\&") + ("\\`\\(ebuild\\|emacs\\|install\\|fast-install\\)\\.cmd\\'" "\\1.bat") + ("\\`\\(book-spine\\|cl\\|forms\\|functions\\|gnus\\|sc\\|texinfo\\|vip\\)\ +\\.texinfo\\'" "\\1.texi") + ("\\`\\(\\(calc\\|org\\|vip\\)card\\|viperCard\\|\ +\\(\\(cs\\|fr\\|sk\\)-\\)?dired-ref\\|\ +\\(\\(cs\\|de\\|fr\\|gnus\\|pl\\|pt-br\\|ru\\|sk\\)-\\)?refcard\\|\ +\\(\\(cs\\|fr\\|sk\\)-\\)?survival\\)\\.tex\\'" "refcards/\\&") + ("\\`refcard-\\(de\\|pl\\)\\.tex\\'" "refcards/\\1-refcard.tex") + ("\\`\\(refcards/\\)?fr-drdref\\.tex\\'" "refcards/fr-dired-ref.tex") + ("^\\(TUTORIAL[^/]*\\)" "tutorials/\\1") + ("\\`themes/dev-\\(tsdh-\\(?:light\\|dark\\)-theme\\.el\\)\\'" + "themes/\\1") + ;; Moved from lisp/toolbar to etc/images. + ("\\`toolbar/\\(back\\|fwd\\|left\\|right\\|up\\)_arrow\ +\\(\\.\\(?:pb\\|xp\\)m\\)\\'" "images/\\1-arrow\\2") + ("\\`toolbar/lc-\\(back\\|fwd\\|left\\|right\\|up\\)_arrow\ +\\(\\.\\(?:pb\\|xp\\)m\\)\\'" "images/low-color/\\1-arrow\\2") + ("\\`toolbar/mail_\\(compose\\|send\\)\\(\\.[xp]bm\\)\\'" + "images/mail/\\1") + ("\\`toolbar/jump_to\\(\\.\\(?:pb\\|xp\\)m\\)\\'" "images/jump-to\\1") + ("\\`toolbar/lc-jump_to\\(\\.\\(?:pb\\|xp\\)m\\)\\'" + "images/low-color/jump-to\\1") + ("\\`toolbar/\\(attach\\|cancel\\|close\\|copy\\|cut\\|\ +diropen\\|exit\\|help\\|home\\|index\\|info\\|mail\\|new\\|open\\|\ +paste\\|preferences\\|print\\|save\\|saveas\\|search\\|search-replace\\|\ +spell\\|undo\\)\\(\\.\\(?:pb\\|xp\\)m\\)\\'" "images/\\1\\2") + ("\\`toolbar/gud-\\(break\\|cont\\|down\\|finish\\|print\\|pstar\\|\ +remove\\|run\\|until\\|up\\|watch\\)\\(\\.\\(?:pb\\|xp\\)m\\)\\'" + "images/gud/\\1\\2") + ("\\`\\(toolbar/gud-\\|images/gud/\\)n\\(i\\)?\\(\\.\\(?:pb\\|xp\\)m\\)\\'" + "images/gud/next\\2\\3") + ("\\`\\(toolbar/gud-\\|images/gud/\\)s\\(i\\)?\\(\\.\\(?:pb\\|xp\\)m\\)\\'" + "images/gud/step\\2\\3") + ("\\`toolbar/lc-\\([-a-z]+\\.xpm\\)\\'" "images/low-color/\\1") + ("^\\(tree-widget/\\(?:default\\|folder\\)/[-a-z]+\\.\\(png\\|xpm\\)\\)$" "images/\\1") - ("^\\(images/icons/\\)mac\\(emacs\\)_\\([0-9]+\\)\\(\\.png\\)" . + ("^\\(images/icons/\\)mac\\(emacs\\)_\\([0-9]+\\)\\(\\.png\\)" "\\1\\2\\3_mac\\4") - ("\\(images/icons/\\)emacs_\\([0-9][0-9]\\)\\.png" . + ("\\(images/icons/\\)emacs_\\([0-9][0-9]\\)\\.png" "\\1hicolor/\\2x\\2/apps/emacs.png") + ;; Moved from leim/ to lisp/leim/. + ("\\`quail/[-a-z0-9]+\\.el\\'" "leim/\\&") + ("\\`ja-dic/ja-dic\\.el\\'" "leim/\\&") + ("\\`vc-\\(rcs\\|cvs\\|sccs\\)-hooks\\.el\\'" "vc/vc-\\1.el") + ("\\`vc-\\(annotate\\|arch\\|bzr\\|cvs\\|dav\\|dir\\|dispatcher\\|\ +git\\|hg\\|hooks\\|mtn\\|rcs\\|sccs\\|svn\\)\\.el\\'" "vc/\\&") + ("\\`ediff-\\(diff\\|help\\|hook\\|init\\|merg\\|mult\\|ptch\\|util\\|\ +vers\\|wind\\)\\.el\\'" "vc/\\&") + ("\\`pcvs-\\(defs\\|info\\|parse\\|util\\)\\.el\\'" "vc/\\&") + ("\\`\\(add-log\\|compare-w\\|cvs-status\\|diff-mode\\|diff\\|\ +ediff\\|emerge\\|log-edit\\|log-view\\|pcvs\\|smerge-mode\\|vc\\)\\.el\\'" + "vc/\\&") + ("\\`\\(emacs-lisp/\\)?helpers\\.el\\'" "emacs-lisp/subr-x.el") + ;; I assume this is (essentially) what happened, org/ChangeLog is vague. + ("\\`org-\\(ascii\\|beamer\\|html\\|icalendar\\|jsinfo\\|latex\ +\\|odt\\|publish\\)\\.el\\'" "ox-\\1.el") + ;; From test/ to test/automated/. + ("comint-testsuite.el" "automated/\\&") + ("\\`\\(bytecomp\\|font-parse\\|icalendar\\|occur\\|newsticker\\)\ +-testsuite\\.el" "automated/\\1-tests.el") + ;; NB lax rules should come last. + ("^m/m-\\(.*\\.h\\)$" "m/\\1" t) + ("^m-\\(.*\\.h\\)$" "\\1" t) + ("^s/s-\\(.*\\.h\\)$" "s/\\1" t) + ("^s-\\(.*\\.h\\)$" "\\1" t) + ("\\.\\(el\\|[ch]\\|x[pb]m\\|pbm\\)\\'" t t) ) - "List regexps and rewriting rules for renamed files. -Elements are (REGEXP . REPLACE). If REPLACE is a string, the file + "List of regexps and rewriting rules for renamed files. +Elements are (REGEXP REPLACE [LAX]). If REPLACE is a string, the file name matching REGEXP is replaced by REPLACE using `replace-string'. -Otherwise, the file name is accepted as is.") +Otherwise, the file name is accepted as is. +Elements with LAX non-nil are only used in `authors-lax-changelogs'.") + +;; It's really not worth trying to make these old logs fully valid. +;; All the obvious real errors are gone. +;; The main issue is _lots_ of moving around of files. +;; Eg the progmodes/ (etc) directories did not exist before 1997. +;; Also, lib-src/ did not exist, the files were in etc/. +;; And various other things. +;; Maybe this should just be any ChangeLog with a . extension, +;; assuming we always fix logs fully before rotating them? +(defconst authors-lax-changelogs + '("erc/ChangeLog\\.0[1-8]\\'" + "gnus/ChangeLog\\.[1-2]\\'" + "lisp/ChangeLog\\.\\([1-9]\\|1[0-5]\\)\\'" + "mh-e/ChangeLog\\.1\\'" + "src/ChangeLog\\.\\([1-9]\\|1[0-2]\\)\\'") + "List of regexps matching ChangeLogs that we do not print errors from. +These are older ChangeLogs that have various issues. +Additionally, for these logs we apply the `lax' elements of +`authors-renamed-files-regexps'.") + (defvar authors-checked-files-alist) (defvar authors-invalid-file-names) +;; This has become rather yucky. :( (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))))) + dir parent) + (if (and (member relname authors-ambiguous-files) + ;; Try to identify the top-level directory. + ;; FIXME should really use ROOT from M-x authors. + (not (and (file-directory-p + (expand-file-name + "lib-src" + (setq dir (file-name-directory fullname)))) + (file-directory-p (expand-file-name "etc" dir))))) + ;; I think it looks weird to see eg "lisp/simple.el". + ;; But for eg Makefile.in, we do want to say "lisp/Makefile.in". + (if (and (string-equal "lisp" + (setq parent (file-name-nondirectory + (directory-file-name dir)))) + ;; TODO better to simply have hard-coded list? + ;; Only really Makefile.in where this applies. + (not (file-exists-p + (expand-file-name (concat "../" relname) dir)))) relname - (format "%s/%s" parent relname)) + ;; In case of ambiguity, just prepend the parent directory. + ;; FIXME obviously this is not a perfect solution. + (format "%s/%s" (file-name-nondirectory (directory-file-name dir)) + relname)) relname))) +(defun authors-lax-changelog-p (file) + "Return non-nil if FILE matches `authors-lax-changelogs'." + (let ((list authors-lax-changelogs) + found) + (while list + (setq list (if (setq found (string-match-p (car list) file)) + nil + (cdr list)))) + found)) + (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, @@ -722,35 +981,39 @@ to print a message if FILE is not found." ;; 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)) - relname - valid) + laxlog relname valid) (if entry (cdr entry) (setq relname (file-name-nondirectory file)) - (if (or (member relname authors-valid-file-names) + (if (or (member file authors-valid-file-names) + (member relname authors-valid-file-names) (file-exists-p file) - (file-exists-p relname) - (file-exists-p (concat "etc/" relname))) + (file-exists-p relname) ; FIXME? appropriate? + ) (setq valid (authors-disambiguate-file-name fullname)) - (setq valid (assoc file authors-renamed-files-alist)) - (if valid + (if (setq valid (assoc file authors-renamed-files-alist)) (setq valid (cdr valid)) - (let ((rules authors-renamed-files-regexps)) + (setq laxlog (authors-lax-changelog-p log-file)) + (let ((rules authors-renamed-files-regexps) + rule) (while rules - (if (string-match (car (car rules)) file) - (setq valid (if (stringp (cdr (car rules))) + (setq rule (car rules)) + (if (and (or laxlog (not (nth 2 rule))) + (string-match (car rule) file)) + (setq valid (if (stringp (nth 1 rule)) (file-name-nondirectory - (replace-match (cdr (car rules)) t nil file)) + (replace-match (nth 1 rule) t nil file)) relname) - rules nil)) - (setq rules (cdr rules)))))) + rules nil) + (setq rules (cdr rules))))))) (setq authors-checked-files-alist (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)) + (string-match "^[0-9.]+$" file) + laxlog) (setq authors-invalid-file-names (cons (format "%s:%d: unrecognized `%s' for %s" log-file @@ -1023,7 +1286,7 @@ buffer *Authors Errors* containing references to unknown files." Foundation's distribution of GNU Emacs. To show our appreciation for their public spirit, we list here in alphabetical order a condensed list of their contributions.\n") - (let (authors-author-list a) + (let (authors-author-list) (maphash #'authors-add-to-author-list table) (setq authors-author-list (sort authors-author-list @@ -1032,8 +1295,7 @@ list of their contributions.\n") (let ((author (car a)) (wrote (nth 1 a)) (cowrote (nth 2 a)) - (changed (nth 3 a)) - file) + (changed (nth 3 a))) (insert "\n" author ": ") (when wrote (insert "wrote") diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index edaecd7ff19..361e8fa7c68 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1,6 +1,6 @@ ;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*- -;; Copyright (C) 1991-1997, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1991-1997, 2001-2014 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Keywords: maint @@ -31,6 +31,7 @@ ;;; Code: (require 'lisp-mode) ;for `doc-string-elt' properties. +(require 'lisp-mnt) (require 'help-fns) ;for help-add-fundoc-usage. (eval-when-compile (require 'cl-lib)) @@ -52,7 +53,10 @@ FormFeed character.") (defvar generated-autoload-load-name nil "Load name for `autoload' statements generated from autoload cookies. -If nil, this defaults to the file name, sans extension.") +If nil, this defaults to the file name, sans extension. +Typically, you need to set this when the directory containing the file +is not in `load-path'. +This also affects the generated cus-load.el file.") ;;;###autoload (put 'generated-autoload-load-name 'safe-local-variable 'stringp) @@ -432,6 +436,57 @@ Return non-nil in the case where no autoloads were added at point." (defvar print-readably) + +(defun autoload--setup-output (otherbuf outbuf absfile load-name) + (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 + (point-marker)))) + +(defun autoload--print-cookie-text (output-start load-name file) + (let ((standard-output (marker-buffer output-start))) + (search-forward generate-autoload-cookie) + (skip-chars-forward " \t") + (if (eolp) + (condition-case-unless-debug err + ;; Read the next form and make an autoload. + (let* ((form (prog1 (read (current-buffer)) + (or (bolp) (forward-line 1)))) + (autoload (make-autoload form load-name))) + (if autoload + nil + (setq autoload form)) + (let ((autoload-print-form-outbuf + standard-output)) + (autoload-print-form autoload))) + (error + (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 + (progn + ;; Back up over whitespace, to preserve it. + (skip-chars-backward " \f\t") + (if (= (char-after (1+ (point))) ? ) + ;; Eat one space. + (forward-char 1)) + (point)) + (progn (forward-line 1) (point))))))) + +(defvar autoload-builtin-package-versions nil) + ;; When called from `generate-file-autoloads' we should ignore ;; `generated-autoload-file' altogether. When called from ;; `update-file-autoloads' we don't know `outbuf'. And when called from @@ -453,8 +508,7 @@ different from OUTFILE, then OUTBUF is ignored. Return non-nil if and only if FILE adds no autoloads to OUTFILE \(or OUTBUF if OUTFILE is nil)." (catch 'done - (let ((autoloads-done '()) - load-name + (let (load-name (print-length nil) (print-level nil) (print-readably t) ; This does something in Lucid Emacs. @@ -463,7 +517,7 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (otherbuf nil) (absfile (expand-file-name file)) ;; nil until we found a cookie. - output-start ostart) + output-start) (with-current-buffer (or visited ;; It is faster to avoid visiting the file. (autoload-find-file file)) @@ -474,6 +528,9 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (if (stringp generated-autoload-load-name) generated-autoload-load-name (autoload-file-load-name absfile))) + ;; FIXME? Comparing file-names for equality with just equal + ;; is fragile, eg if one has an automounter prefix and one + ;; does not, but both refer to the same physical file. (when (and outfile (not (if (memq system-type '(ms-dos windows-nt)) @@ -484,6 +541,23 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (save-excursion (save-restriction (widen) + (when autoload-builtin-package-versions + (let ((version (lm-header "version")) + package) + (and version + (setq version (ignore-errors (version-to-list version))) + (setq package (or (lm-header "package") + (file-name-sans-extension + (file-name-nondirectory file)))) + (setq output-start (autoload--setup-output + otherbuf outbuf absfile load-name)) + (let ((standard-output (marker-buffer output-start)) + (print-quoted t)) + (princ `(push (purecopy + ',(cons (intern package) version)) + package--builtin-versions)) + (princ "\n"))))) + (goto-char (point-min)) (while (not (eobp)) (skip-chars-forward " \t\n\f") @@ -491,51 +565,9 @@ 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 - (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-unless-debug err - ;; Read the next form and make an autoload. - (let* ((form (prog1 (read (current-buffer)) - (or (bolp) (forward-line 1)))) - (autoload (make-autoload form load-name))) - (if autoload - (push (nth 1 form) autoloads-done) - (setq autoload form)) - (let ((autoload-print-form-outbuf - (marker-buffer output-start))) - (autoload-print-form autoload))) - (error - (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 - (progn - ;; Back up over whitespace, to preserve it. - (skip-chars-backward " \f\t") - (if (= (char-after (1+ (point))) ? ) - ;; Eat one space. - (forward-char 1)) - (point)) - (progn (forward-line 1) (point))) - (marker-buffer output-start)))) + (setq output-start (autoload--setup-output + otherbuf outbuf absfile load-name))) + (autoload--print-cookie-text output-start load-name file)) ((looking-at ";") ;; Don't read the comment. (forward-line 1)) @@ -550,12 +582,11 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (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) (let ((relfile (file-relative-name absfile))) (autoload-insert-section-header (marker-buffer output-start) - autoloads-done load-name relfile + () 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 diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 4481bc9ae61..813576efb46 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -1,12 +1,12 @@ ;;; avl-tree.el --- balanced binary trees, AVL-trees -;; Copyright (C) 1995, 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2007-2014 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> ;; Inge Wallin <inge@lysator.liu.se> ;; Thomas Bellman <bellman@lysator.liu.se> ;; Toby Cubitt <toby-predictive@dr-qubit.org> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Created: 10 May 1991 ;; Keywords: extensions, data structures, AVL, tree diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index 2dc84e9ddfb..a497acd637e 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -1,10 +1,10 @@ ;;; backquote.el --- implement the ` Lisp construct -;; Copyright (C) 1990, 1992, 1994, 2001-2013 Free Software Foundation, +;; Copyright (C) 1990, 1992, 1994, 2001-2014 Free Software Foundation, ;; Inc. ;; Author: Rick Sladkey <jrs@world.std.com> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: extensions, internal ;; Package: emacs @@ -153,11 +153,18 @@ LEVEL is only used internally and indicates the nesting level: (list 'quote s)))) ((eq (car s) backquote-unquote-symbol) (if (<= level 0) - (cons 1 (nth 1 s)) + (if (> (length s) 2) + ;; We could support it with: (cons 2 `(list . ,(cdr s))) + ;; But let's not encourage such uses. + (error "Multiple args to , are not supported: %S" s) + (cons 1 (nth 1 s))) (backquote-delay-process s (1- level)))) ((eq (car s) backquote-splice-symbol) (if (<= level 0) - (cons 2 (nth 1 s)) + (if (> (length s) 2) + ;; (cons 2 `(append . ,(cdr s))) + (error "Multiple args to ,@ are not supported: %S" s) + (cons 2 (nth 1 s))) (backquote-delay-process s (1- level)))) ((eq (car s) backquote-backquote-symbol) (backquote-delay-process s (1+ level))) diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index c97b33f4e7d..f1fec813e95 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -1,6 +1,6 @@ ;;; benchmark.el --- support for benchmarking code -;; Copyright (C) 2003-2013 Free Software Foundation, Inc. +;; Copyright (C) 2003-2014 Free Software Foundation, Inc. ;; Author: Dave Love <fx@gnu.org> ;; Keywords: lisp, extensions diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 86d72fef9b5..92aa2f301f5 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-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2014 Free Software Foundation, Inc. ;; Author: Kim F. Storm <storm@cua.dk> ;; Assignment name: struct.el diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 7375c2176ba..b1e06410da4 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1,10 +1,10 @@ ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*- -;; Copyright (C) 1991, 1994, 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1994, 2000-2014 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal ;; Package: emacs @@ -248,10 +248,10 @@ (defun byte-compile-inline-expand (form) (let* ((name (car form)) (localfn (cdr (assq name byte-compile-function-environment))) - (fn (or localfn (and (fboundp name) (symbol-function name))))) + (fn (or localfn (symbol-function name)))) (when (autoloadp fn) (autoload-do-load fn) - (setq fn (or (and (fboundp name) (symbol-function name)) + (setq fn (or (symbol-function name) (cdr (assq name byte-compile-function-environment))))) (pcase fn (`nil @@ -287,6 +287,7 @@ (byte-compile--reify-function fn))))) (if (eq (car-safe newfn) 'function) (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) + ;; This can happen because of macroexp-warn-and-return &co. (byte-compile-log-warning (format "Inlining closure %S failed" name)) form)))) @@ -487,11 +488,22 @@ (prin1-to-string form)) nil) - ((memq fn '(function condition-case)) - ;; These forms are compiled as constants or by breaking out + ((eq fn 'function) + ;; This forms is compiled as constant or by breaking out ;; all the subexpressions and compiling them separately. form) + ((eq fn 'condition-case) + (if byte-compile--use-old-handlers + ;; Will be optimized later. + form + `(condition-case ,(nth 1 form) ;Not evaluated. + ,(byte-optimize-form (nth 2 form) for-effect) + ,@(mapcar (lambda (clause) + `(,(car clause) + ,@(byte-optimize-body (cdr clause) for-effect))) + (nthcdr 3 form))))) + ((eq fn 'unwind-protect) ;; the "protected" part of an unwind-protect is compiled (and thus ;; optimized) as a top-level form, so don't do it here. But the @@ -503,13 +515,14 @@ (cdr (cdr form))))) ((eq fn 'catch) - ;; the body of a catch is compiled (and thus optimized) as a - ;; top-level form, so don't do it here. The tag is never - ;; for-effect. The body should have the same for-effect status - ;; as the catch form itself, but that isn't handled properly yet. (cons fn (cons (byte-optimize-form (nth 1 form) nil) - (cdr (cdr form))))) + (if byte-compile--use-old-handlers + ;; The body of a catch is compiled (and thus + ;; optimized) as a top-level form, so don't do it + ;; here. + (cdr (cdr form)) + (byte-optimize-body (cdr form) for-effect))))) ((eq fn 'ignore) ;; Don't treat the args to `ignore' as being @@ -532,18 +545,6 @@ ((and for-effect (setq tmp (get fn 'side-effect-free)) (or byte-compile-delete-errors (eq tmp 'error-free) - ;; Detect the expansion of (pop foo). - ;; There is no need to compile the call to `car' there. - (and (eq fn 'car) - (eq (car-safe (cadr form)) 'prog1) - (let ((var (cadr (cadr form))) - (last (nth 2 (cadr form)))) - (and (symbolp var) - (null (nthcdr 3 (cadr form))) - (eq (car-safe last) 'setq) - (eq (cadr last) var) - (eq (car-safe (nth 2 last)) 'cdr) - (eq (cadr (nth 2 last)) var)))) (progn (byte-compile-warn "value returned from %s is unused" (prin1-to-string form)) @@ -1303,7 +1304,7 @@ "Don't call this!" ;; Fetch and return the offset for the current opcode. ;; Return nil if this opcode has no offset. - (cond ((< bytedecomp-op byte-nth) + (cond ((< bytedecomp-op byte-pophandler) (let ((tem (logand bytedecomp-op 7))) (setq bytedecomp-op (logand bytedecomp-op 248)) (cond ((eq tem 6) @@ -1322,7 +1323,9 @@ (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)) + (memq bytedecomp-op (eval-when-compile + (list byte-stack-set2 byte-pushcatch + byte-pushconditioncase)))) ;; Offset in next 2 bytes. (setq bytedecomp-ptr (1+ bytedecomp-ptr)) (+ (aref bytes bytedecomp-ptr) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 48bcefaee1a..4b9e6d8fd23 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -1,10 +1,10 @@ ;;; byte-run.el --- byte-compiler support for inlining -*- lexical-binding: t -*- -;; Copyright (C) 1992, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2014 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal ;; Package: emacs @@ -79,10 +79,10 @@ The return value of this function is not used." (list 'quote f) (list 'quote arglist) (list 'quote when)))) (list 'obsolete #'(lambda (f _args new-name when) - `(make-obsolete ',f ',new-name ,when))) + (list 'make-obsolete + (list 'quote f) (list 'quote new-name) (list 'quote when)))) (list 'compiler-macro #'(lambda (f args compiler-function) - ;; FIXME: Make it possible to just reuse `args'. `(eval-and-compile (put ',f 'compiler-macro ,(if (eq (car-safe compiler-function) 'lambda) @@ -112,12 +112,13 @@ to set this property.") ''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.") +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 macro name, the macro's arglist, and the VALUES +and should return the code to use to set this property.") (put 'defmacro 'doc-string-elt 3) +(put 'defmacro 'lisp-indent-function 2) (defalias 'defmacro (cons 'macro @@ -179,7 +180,7 @@ The return value is undefined. ;; (defun foo (arg) (toto) nil) ;; from ;; (defun foo (arg) (toto)). - (declare (doc-string 3)) + (declare (doc-string 3) (indent 2)) (let ((decls (cond ((eq (car-safe docstring) 'declare) (prog1 (cdr docstring) (setq docstring nil))) @@ -284,7 +285,6 @@ 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: ") (put obsolete-name 'byte-obsolete-info ;; The second entry used to hold the `byte-compile' handler, but ;; is not used any more nowadays. @@ -378,7 +378,7 @@ obsolete." (defmacro dont-compile (&rest body) "Like `progn', but the body always runs interpreted (not compiled). If you think you need this, you're probably making a mistake somewhere." - (declare (debug t) (indent 0)) + (declare (debug t) (indent 0) (obsolete nil "24.4")) (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body))))) @@ -391,7 +391,7 @@ If you think you need this, you're probably making a mistake somewhere." "Like `progn', but evaluates the body at compile time if you're compiling. Thus, the result of the body appears to the compiler as a quoted constant. In interpreted code, this is entirely equivalent to `progn'." - (declare (debug t) (indent 0)) + (declare (debug (&rest def-form)) (indent 0)) (list 'quote (eval (cons 'progn body) lexical-binding))) (defmacro eval-and-compile (&rest body) @@ -402,9 +402,9 @@ In interpreted code, this is entirely equivalent to `progn'." ;; macroexpansion. (list 'quote (eval (cons 'progn body) lexical-binding))) -(put 'with-no-warnings 'lisp-indent-function 0) (defun with-no-warnings (&rest body) "Like `progn', but prevents compiler warnings in the body." + (declare (indent 0)) ;; The implementation for the interpreter is basically trivial. (car (last body))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5db1793a407..e2e468717a6 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1,11 +1,11 @@ ;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*- -;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2013 Free Software +;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2014 Free Software ;; Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp ;; Package: emacs @@ -289,10 +289,11 @@ Elements of the list may be: obsolete obsolete variables and functions. noruntime functions that may not be defined at runtime (typically defined only under `eval-when-compile'). - cl-functions calls to runtime functions from the CL package (as - distinguished from macros and aliases). + cl-functions calls to runtime functions (as distinguished from macros and + aliases) from the old CL package (not the newer cl-lib). interactive-only commands that normally shouldn't be called from Lisp code. + lexical global/dynamic variables lacking a prefix. make-local calls to make-variable-buffer-local that may be incorrect. mapcar mapcar called for effect. constants let-binding of, or assignment to, constants/nonvariables. @@ -352,11 +353,11 @@ else the global value will be modified." (t (append byte-compile-warnings (list warning))))))) -(defvar byte-compile-interactive-only-functions - '(beginning-of-buffer end-of-buffer replace-string replace-regexp - insert-file insert-buffer insert-file-literally previous-line next-line - goto-line comint-run delete-backward-char) +(defvar byte-compile-interactive-only-functions nil "List of commands that are not meant to be called from Lisp.") +(make-obsolete-variable 'byte-compile-interactive-only-functions + "use the `interactive-only' symbol property instead." + "24.4") (defvar byte-compile-not-obsolete-vars nil "List of variables that shouldn't be reported as obsolete.") @@ -410,6 +411,9 @@ specify different fields to sort on." (defvar byte-compile-bound-variables nil "List of dynamic variables bound in the context of the current form. This list lives partly on the stack.") +(defvar byte-compile-lexical-variables nil + "List of variables that have been treated as lexical. +Filled in `cconv-analyse-form' but initialized and consulted here.") (defvar byte-compile-const-variables nil "List of variables declared as constants during compilation of this file.") (defvar byte-compile-free-references) @@ -531,7 +535,13 @@ Each element is (INDEX . VALUE)") (byte-defop 40 0 byte-unbind "for unbinding special bindings") ;; codes 8-47 are consumed by the preceding opcodes -;; unused: 48-55 +;; New (in Emacs-24.4) bytecodes for more efficient handling of non-local exits +;; (especially useful in lexical-binding code). +(byte-defop 48 0 byte-pophandler) +(byte-defop 50 -1 byte-pushcatch) +(byte-defop 49 -1 byte-pushconditioncase) + +;; unused: 51-55 (byte-defop 56 -1 byte-nth) (byte-defop 57 0 byte-symbolp) @@ -703,7 +713,8 @@ otherwise pop it") (defconst byte-goto-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop) + byte-goto-if-not-nil-else-pop + byte-pushcatch byte-pushconditioncase) "List of byte-codes whose offset is a pc.") (defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil)) @@ -1220,6 +1231,24 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (format "%d" (car signature))) (t (format "%d-%d" (car signature) (cdr signature))))) +(defun byte-compile-function-warn (f nargs def) + (when (get f 'byte-obsolete-info) + (byte-compile-warn-obsolete f)) + + ;; Check to see if the function will be available at runtime + ;; and/or remember its arity if it's unknown. + (or (and (or def (fboundp f)) ; might be a subr or autoload. + (not (memq f byte-compile-noruntime-functions))) + (eq f 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 f byte-compile-unresolved-functions))) + (if cons + (or (memq nargs (cdr cons)) + (push nargs (cdr cons))) + (push (list f nargs) + byte-compile-unresolved-functions))))) ;; Warn if the form is calling a function with the wrong number of arguments. (defun byte-compile-callargs-warn (form) @@ -1236,8 +1265,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (if (byte-code-function-p def) (aref def 0) '(&rest def))))) - (if (and (fboundp (car form)) - (subrp (symbol-function (car form)))) + (if (subrp (symbol-function (car form))) (subr-arity (symbol-function (car form)))))) (ncall (length (cdr form)))) ;; Check many or unevalled from subr-arity. @@ -1257,21 +1285,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." "accepts only") (byte-compile-arglist-signature-string sig)))) (byte-compile-format-warn form) - ;; Check to see if the function will be available at runtime - ;; 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. - ;; It's a currently-undefined function. - ;; Remember number of args in call. - (let ((cons (assq (car form) byte-compile-unresolved-functions)) - (n (length (cdr form)))) - (if cons - (or (memq n (cdr cons)) - (setcdr cons (cons n (cdr cons)))) - (push (list (car form) n) - byte-compile-unresolved-functions)))))) + (byte-compile-function-warn (car form) (length (cdr form)) def))) (defun byte-compile-format-warn (form) "Warn if FORM is `format'-like with inconsistent args. @@ -1360,7 +1374,10 @@ extra args." ;; This is the first definition. See if previous calls are compatible. (let ((calls (assq name byte-compile-unresolved-functions)) nums sig min max) - (when calls + (setq byte-compile-unresolved-functions + (delq calls byte-compile-unresolved-functions)) + (setq calls (delq t calls)) ;Ignore higher-order uses of the function. + (when (cdr calls) (when (and (symbolp name) (eq (function-get name 'byte-optimizer) 'byte-compile-inline-expand)) @@ -1378,10 +1395,7 @@ extra args." 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))))))) + (byte-compile-arglist-signature-string (cons min max))))))))) (defvar byte-compile-cl-functions nil "List of functions defined in CL.") @@ -1488,6 +1502,7 @@ extra args." (byte-compile--outbuffer nil) (byte-compile-function-environment nil) (byte-compile-bound-variables nil) + (byte-compile-lexical-variables nil) (byte-compile-const-variables nil) (byte-compile-free-references nil) (byte-compile-free-assignments nil) @@ -1584,14 +1599,14 @@ that already has a `.elc' file." (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)))) + (if (file-directory-p source) + (and (not (member file '("RCS" "CVS"))) + (not (eq ?\. (aref file 0))) + (not (file-symlink-p source)) + ;; This file is a subdirectory. Handle them differently. + (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) ;; The next 2 tests avoid compiling lock files @@ -1690,16 +1705,14 @@ The value is non-nil if there were no errors, nil if errors." ;; (interactive "fByte compile file: \nP") (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))) + (setq file-dir (file-name-directory file))) (list (read-file-name (if current-prefix-arg "Byte compile and load file: " "Byte compile file: ") - file-dir file-name nil) + file-dir buffer-file-name nil) current-prefix-arg))) ;; Expand now so we get the current buffer's defaults (setq filename (expand-file-name filename)) @@ -1978,7 +1991,7 @@ and will be removed soon. See (elisp)Backquote in the manual.")) (widen) (delete-char delta)))) -(defun byte-compile-insert-header (filename outbuffer) +(defun byte-compile-insert-header (_filename outbuffer) "Insert a header at the start of OUTBUFFER. Call from the source buffer." (let ((dynamic-docstrings byte-compile-dynamic-docstrings) @@ -1997,11 +2010,7 @@ Call from the source buffer." ;; >4 byte x version %d (insert ";ELC" 23 "\000\000\000\n" - ";;; Compiled by " - (or (and (boundp 'user-mail-address) user-mail-address) - (concat (user-login-name) "@" (system-name))) - " on " (current-time-string) "\n" - ";;; from file " filename "\n" + ";;; Compiled\n" ";;; in Emacs version " emacs-version "\n" ";;; with" (cond @@ -2173,6 +2182,8 @@ list that represents a doc string reference. byte-compile-maxdepth 0 byte-compile-output nil)))) +(defvar byte-compile-force-lexical-warnings 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 @@ -2181,9 +2192,10 @@ list that represents a doc string reference. ;; macroexpand-all. ;; (if (memq byte-optimize '(t source)) ;; (setq form (byte-optimize-form form for-effect))) - (if lexical-binding - (cconv-closure-convert form) - form)) + (cond + (lexical-binding (cconv-closure-convert form)) + (byte-compile-force-lexical-warnings (cconv-warnings-only form)) + (t form))) ;; byte-hunk-handlers cannot call this! (defun byte-compile-toplevel-file-form (form) @@ -2210,32 +2222,33 @@ list that represents a doc string reference. (defun byte-compile-file-form-autoload (form) (and (let ((form 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. + (null form)) ;Constants only + (memq (eval (nth 5 form)) '(t macro)) ;Macro + (eval form)) ;Define the autoload. ;; Avoid undefined function warnings for the autoload. - (when (and (consp (nth 1 form)) - (eq (car (nth 1 form)) 'quote) - (consp (cdr (nth 1 form))) - (symbolp (nth 1 (nth 1 form))) - ;; Don't add it if it's already defined. Otherwise, it might - ;; hide the actual definition. - (not (fboundp (nth 1 (nth 1 form))))) - (push (cons (nth 1 (nth 1 form)) - (cons 'autoload (cdr (cdr form)))) - byte-compile-function-environment) - ;; If an autoload occurs _before_ the first call to a function, - ;; byte-compile-callargs-warn does not add an entry to - ;; byte-compile-unresolved-functions. Here we mimic the logic - ;; of byte-compile-callargs-warn so as not to warn if the - ;; autoload comes _after_ the function call. - ;; Alternatively, similar logic could go in - ;; byte-compile-warn-about-unresolved-functions. - (or (memq (nth 1 (nth 1 form)) byte-compile-noruntime-functions) - (setq byte-compile-unresolved-functions - (delq (assq (nth 1 (nth 1 form)) - byte-compile-unresolved-functions) - byte-compile-unresolved-functions)))) + (pcase (nth 1 form) + (`',(and (pred symbolp) funsym) + ;; Don't add it if it's already defined. Otherwise, it might + ;; hide the actual definition. However, do remove any entry from + ;; byte-compile-noruntime-functions, in case we have an autoload + ;; of foo-func following an (eval-when-compile (require 'foo)). + (unless (fboundp funsym) + (push (cons funsym (cons 'autoload (cdr (cdr form)))) + byte-compile-function-environment)) + ;; If an autoload occurs _before_ the first call to a function, + ;; byte-compile-callargs-warn does not add an entry to + ;; byte-compile-unresolved-functions. Here we mimic the logic + ;; of byte-compile-callargs-warn so as not to warn if the + ;; autoload comes _after_ the function call. + ;; Alternatively, similar logic could go in + ;; byte-compile-warn-about-unresolved-functions. + (if (memq funsym byte-compile-noruntime-functions) + (setq byte-compile-noruntime-functions + (delq funsym byte-compile-noruntime-functions) + byte-compile-noruntime-functions) + (setq byte-compile-unresolved-functions + (delq (assq funsym byte-compile-unresolved-functions) + byte-compile-unresolved-functions))))) (if (stringp (nth 3 form)) form ;; No doc string, so we can compile this as a normal form. @@ -2243,15 +2256,24 @@ list that represents a doc string reference. (put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) (put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) -(defun byte-compile-file-form-defvar (form) - (when (and (symbolp (nth 1 form)) - (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) + +(defun byte-compile--declare-var (sym) + (when (and (symbolp sym) + (not (string-match "[-*/:$]" (symbol-name sym))) (byte-compile-warning-enabled-p 'lexical)) (byte-compile-warn "global/dynamic var `%s' lacks a prefix" - (nth 1 form))) - (push (nth 1 form) byte-compile-bound-variables) - (if (eq (car form) 'defconst) - (push (nth 1 form) byte-compile-const-variables)) + sym)) + (when (memq sym byte-compile-lexical-variables) + (setq byte-compile-lexical-variables + (delq sym byte-compile-lexical-variables)) + (byte-compile-warn "Variable `%S' declared after its first use" sym)) + (push sym byte-compile-bound-variables)) + +(defun byte-compile-file-form-defvar (form) + (let ((sym (nth 1 form))) + (byte-compile--declare-var sym) + (if (eq (car form) 'defconst) + (push sym byte-compile-const-variables))) (if (and (null (cddr form)) ;No `value' provided. (eq (car form) 'defvar)) ;Just a declaration. nil @@ -2265,7 +2287,7 @@ list that represents a doc string reference. 'byte-compile-file-form-define-abbrev-table) (defun byte-compile-file-form-define-abbrev-table (form) (if (eq 'quote (car-safe (car-safe (cdr form)))) - (push (car-safe (cdr (cadr form))) byte-compile-bound-variables)) + (byte-compile--declare-var (car-safe (cdr (cadr form))))) (byte-compile-keep-pending form)) (put 'custom-declare-variable 'byte-hunk-handler @@ -2273,7 +2295,7 @@ list that represents a doc string reference. (defun byte-compile-file-form-custom-declare-variable (form) (when (byte-compile-warning-enabled-p 'callargs) (byte-compile-nogroup-warn form)) - (push (nth 1 (nth 1 form)) byte-compile-bound-variables) + (byte-compile--declare-var (nth 1 (nth 1 form))) (byte-compile-keep-pending form)) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) @@ -2371,9 +2393,8 @@ not to take responsibility for the actual compilation of the code." (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))) + ((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") @@ -2507,7 +2528,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-close-variables (let* ((lexical-binding lexical-binding) (fun (if (symbolp form) - (and (fboundp form) (symbol-function form)) + (symbol-function form) form)) (macro (eq (car-safe fun) 'macro))) (if macro @@ -2574,19 +2595,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." "Return a list of the variables in the lambda argument list ARGLIST." (remq '&rest (remq '&optional arglist))) -(defun byte-compile-make-lambda-lexenv (form) +(defun byte-compile-make-lambda-lexenv (args) "Return a new lexical environment for a lambda expression FORM." - ;; See if this is a closure or not - (let ((args (byte-compile-arglist-vars (cadr form)))) - (let ((lexenv nil)) - ;; Fill in the initial stack contents - (let ((stackpos 0)) - ;; Add entries for each argument - (dolist (arg args) - (push (cons arg stackpos) lexenv) - (setq stackpos (1+ stackpos))) - ;; Return the new lexical environment - lexenv)))) + (let* ((lexenv nil) + (stackpos 0)) + ;; Add entries for each argument. + (dolist (arg args) + (push (cons arg stackpos) lexenv) + (setq stackpos (1+ stackpos))) + ;; Return the new lexical environment. + lexenv)) (defun byte-compile-make-args-desc (arglist) (let ((mandatory 0) @@ -2624,9 +2642,9 @@ for symbols generated by the byte compiler itself." (byte-compile-set-symbol-position 'lambda)) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) + (arglistvars (byte-compile-arglist-vars arglist)) (byte-compile-bound-variables - (append (and (not lexical-binding) - (byte-compile-arglist-vars arglist)) + (append (if (not lexical-binding) arglistvars) byte-compile-bound-variables)) (body (cdr (cdr fun))) (doc (if (stringp (car body)) @@ -2674,7 +2692,8 @@ for symbols generated by the byte compiler itself." ;; args (since lambda expressions should be ;; closed by now). (and lexical-binding - (byte-compile-make-lambda-lexenv fun)) + (byte-compile-make-lambda-lexenv + arglistvars)) reserved-csts))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) @@ -2906,15 +2925,24 @@ for symbols generated by the byte compiler itself." (byte-compile-variable-ref form)))) ((symbolp (car form)) (let* ((fn (car form)) - (handler (get fn 'byte-compile))) + (handler (get fn 'byte-compile)) + (interactive-only + (or (get fn 'interactive-only) + (memq fn byte-compile-interactive-only-functions)))) (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)) + (when (and (byte-compile-warning-enabled-p 'interactive-only) + interactive-only) + (byte-compile-warn "`%s' is for interactive use only%s" + fn + (cond ((stringp interactive-only) + (format "; %s" interactive-only)) + ((and (symbolp 'interactive-only) + (not (eq interactive-only t))) + (format "; use `%s' instead." + interactive-only)) + (t ".")))) + (if (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 @@ -2948,8 +2976,6 @@ That command is designed for interactive use only" fn)) '(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)) @@ -3154,6 +3180,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" '((0 . byte-compile-no-args) (1 . byte-compile-one-arg) (2 . byte-compile-two-args) + (2-and . byte-compile-and-folded) (3 . byte-compile-three-args) (0-1 . byte-compile-zero-or-one-arg) (1-2 . byte-compile-one-or-two-args) @@ -3235,11 +3262,11 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler cons 2) (byte-defop-compiler aref 2) (byte-defop-compiler set 2) -(byte-defop-compiler (= byte-eqlsign) 2) -(byte-defop-compiler (< byte-lss) 2) -(byte-defop-compiler (> byte-gtr) 2) -(byte-defop-compiler (<= byte-leq) 2) -(byte-defop-compiler (>= byte-geq) 2) +(byte-defop-compiler (= byte-eqlsign) 2-and) +(byte-defop-compiler (< byte-lss) 2-and) +(byte-defop-compiler (> byte-gtr) 2-and) +(byte-defop-compiler (<= byte-leq) 2-and) +(byte-defop-compiler (>= byte-geq) 2-and) (byte-defop-compiler get 2) (byte-defop-compiler nth 2) (byte-defop-compiler substring 2-3) @@ -3303,6 +3330,16 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-form (nth 2 form)) (byte-compile-out (get (car form) 'byte-opcode) 0))) +(defun byte-compile-and-folded (form) + "Compile calls to functions like `<='. +These implicitly `and' together a bunch of two-arg bytecodes." + (let ((l (length form))) + (cond + ((< l 3) (byte-compile-form `(progn ,(nth 1 form) t))) + ((= l 3) (byte-compile-two-args form)) + (t (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form)) + (,(car form) ,@(nthcdr 2 form)))))))) + (defun byte-compile-three-args (form) (if (not (= (length form) 4)) (byte-compile-subr-wrong-args form 3) @@ -3433,32 +3470,38 @@ discarding." (byte-defop-compiler (/ byte-quo) byte-compile-quo) (byte-defop-compiler nconc) +;; Is this worth it? Both -before and -after are written in C. (defun byte-compile-char-before (form) - (cond ((= 2 (length form)) + (cond ((or (= 1 (length form)) + (and (= 2 (length form)) (not (nth 1 form)))) + (byte-compile-form '(char-after (1- (point))))) + ((= 2 (length form)) (byte-compile-form (list 'char-after (if (numberp (nth 1 form)) (1- (nth 1 form)) - `(1- ,(nth 1 form)))))) - ((= 1 (length form)) - (byte-compile-form '(char-after (1- (point))))) + `(1- (or ,(nth 1 form) + (point))))))) (t (byte-compile-subr-wrong-args form "0-1")))) ;; backward-... ==> forward-... with negated argument. +;; Is this worth it? Both -backward and -forward are written in C. (defun byte-compile-backward-char (form) - (cond ((= 2 (length form)) + (cond ((or (= 1 (length form)) + (and (= 2 (length form)) (not (nth 1 form)))) + (byte-compile-form '(forward-char -1))) + ((= 2 (length form)) (byte-compile-form (list 'forward-char (if (numberp (nth 1 form)) (- (nth 1 form)) - `(- ,(nth 1 form)))))) - ((= 1 (length form)) - (byte-compile-form '(forward-char -1))) + `(- (or ,(nth 1 form) 1)))))) (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-backward-word (form) - (cond ((= 2 (length form)) + (cond ((or (= 1 (length form)) + (and (= 2 (length form)) (not (nth 1 form)))) + (byte-compile-form '(forward-word -1))) + ((= 2 (length form)) (byte-compile-form (list 'forward-word (if (numberp (nth 1 form)) (- (nth 1 form)) - `(- ,(nth 1 form)))))) - ((= 1 (length form)) - (byte-compile-form '(forward-word -1))) + `(- (or ,(nth 1 form) 1)))))) (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-list (form) @@ -3552,9 +3595,14 @@ discarding." ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (byte-compile-constant (if (eq 'lambda (car-safe (nth 1 form))) - (byte-compile-lambda (nth 1 form)) - (nth 1 form)))) + (let ((f (nth 1 form))) + (when (and (symbolp f) + (byte-compile-warning-enabled-p 'callargs)) + (byte-compile-function-warn f t (byte-compile-fdefinition f nil))) + + (byte-compile-constant (if (eq 'lambda (car-safe f)) + (byte-compile-lambda f) + f)))) (defun byte-compile-indent-to (form) (let ((len (length form))) @@ -3860,9 +3908,8 @@ that suppresses all warnings during execution of BODY." "Emit byte-codes to push the initialization value for CLAUSE on the stack. Return the offset in the form (VAR . OFFSET)." (let* ((var (if (consp clause) (car clause) clause))) - ;; We record the stack position even of dynamic bindings and - ;; variables in non-stack lexical environments; we'll put - ;; them in the proper place below. + ;; We record the stack position even of dynamic bindings; we'll put + ;; them in the proper place later. (prog1 (cons var byte-compile-depth) (if (consp clause) (byte-compile-form (cadr clause)) @@ -3880,33 +3927,41 @@ Return the offset in the form (VAR . OFFSET)." INIT-LEXENV should be a lexical-environment alist describing the positions of the init value that have been pushed on the stack. Return non-nil if the TOS value was popped." - ;; The presence of lexical bindings mean that we may have to + ;; The mix of lexical and dynamic bindings mean that we may have to ;; juggle things on the stack, to move them to TOS for ;; dynamic binding. - (cond ((not (byte-compile-not-lexical-var-p var)) - ;; VAR is a simple stack-allocated lexical variable - (push (assq var init-lexenv) - byte-compile--lexical-environment) - nil) - ((eq var (caar init-lexenv)) - ;; VAR is dynamic and is on the top of the - ;; stack, so we can just bind it like usual - (byte-compile-dynamic-variable-bind var) - t) - (t - ;; VAR is dynamic, but we have to get its - ;; value out of the middle of the stack - (let ((stack-pos (cdr (assq var init-lexenv)))) - (byte-compile-stack-ref stack-pos) - (byte-compile-dynamic-variable-bind var) - ;; Now we have to store nil into its temporary - ;; stack position to avoid problems with GC - (byte-compile-push-constant nil) - (byte-compile-stack-set stack-pos)) - nil))) - -(defun byte-compile-unbind (clauses init-lexenv - &optional preserve-body-value) + (if (and lexical-binding (not (byte-compile-not-lexical-var-p var))) + ;; VAR is a simple stack-allocated lexical variable. + (progn (push (assq var init-lexenv) + byte-compile--lexical-environment) + nil) + ;; VAR should be dynamically bound. + (while (assq var byte-compile--lexical-environment) + ;; This dynamic binding shadows a lexical binding. + (setq byte-compile--lexical-environment + (remq (assq var byte-compile--lexical-environment) + byte-compile--lexical-environment))) + (cond + ((eq var (caar init-lexenv)) + ;; VAR is dynamic and is on the top of the + ;; stack, so we can just bind it like usual. + (byte-compile-dynamic-variable-bind var) + t) + (t + ;; VAR is dynamic, but we have to get its + ;; value out of the middle of the stack. + (let ((stack-pos (cdr (assq var init-lexenv)))) + (byte-compile-stack-ref stack-pos) + (byte-compile-dynamic-variable-bind var) + ;; Now we have to store nil into its temporary + ;; stack position so it doesn't prevent the value from being GC'd. + ;; FIXME: Not worth the trouble. + ;; (byte-compile-push-constant nil) + ;; (byte-compile-stack-set stack-pos) + ) + nil)))) + +(defun byte-compile-unbind (clauses init-lexenv preserve-body-value) "Emit byte-codes to unbind the variables bound by CLAUSES. CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a lexical-environment alist describing the positions of the init value that @@ -3914,7 +3969,7 @@ have been pushed on the stack. If PRESERVE-BODY-VALUE is true, then an additional value on the top of the stack, above any lexical binding slots, is preserved, so it will be on the top of the stack after all binding slots have been popped." - ;; Unbind dynamic variables + ;; Unbind dynamic variables. (let ((num-dynamic-bindings 0)) (dolist (clause clauses) (unless (assq (if (consp clause) (car clause) clause) @@ -3925,14 +3980,15 @@ binding slots have been popped." ;; Pop lexical variables off the stack, possibly preserving the ;; return value of the body. (when init-lexenv - ;; INIT-LEXENV contains all init values left on the stack + ;; INIT-LEXENV contains all init values left on the stack. (byte-compile-discard (length init-lexenv) preserve-body-value))) (defun byte-compile-let (form) - "Generate code for the `let' form FORM." + "Generate code for the `let' or `let*' form FORM." (let ((clauses (cadr form)) - (init-lexenv nil)) - (when (eq (car form) 'let) + (init-lexenv nil) + (is-let (eq (car form) 'let))) + (when is-let ;; First compute the binding values in the old scope. (dolist (var clauses) (push (byte-compile-push-binding-init var) init-lexenv))) @@ -3944,28 +4000,20 @@ binding slots have been popped." ;; For `let', do it in reverse order, because it makes no ;; semantic difference, but it is a lot more efficient since the ;; values are now in reverse order on the stack. - (dolist (var (if (eq (car form) 'let) (reverse clauses) clauses)) - (unless (eq (car form) 'let) + (dolist (var (if is-let (reverse clauses) clauses)) + (unless is-let (push (byte-compile-push-binding-init var) init-lexenv)) (let ((var (if (consp var) (car var) var))) - (cond ((null lexical-binding) - ;; If there are no lexical bindings, we can do things simply. - (byte-compile-dynamic-variable-bind var)) - ((byte-compile-bind var init-lexenv) - (pop init-lexenv))))) + (if (byte-compile-bind var init-lexenv) + (pop init-lexenv)))) ;; Emit the body. (let ((init-stack-depth byte-compile-depth)) (byte-compile-body-do-effect (cdr (cdr form))) - ;; Unbind the variables. - (if lexical-binding - ;; Unbind both lexical and dynamic variables. - (progn - (cl-assert (or (eq byte-compile-depth init-stack-depth) - (eq byte-compile-depth (1+ init-stack-depth)))) - (byte-compile-unbind clauses init-lexenv (> byte-compile-depth - init-stack-depth))) - ;; Unbind dynamic variables. - (byte-compile-out 'byte-unbind (length clauses))))))) + ;; Unbind both lexical and dynamic variables. + (cl-assert (or (eq byte-compile-depth init-stack-depth) + (eq byte-compile-depth (1+ init-stack-depth)))) + (byte-compile-unbind clauses init-lexenv + (> byte-compile-depth init-stack-depth)))))) @@ -4003,23 +4051,35 @@ binding slots have been popped." ;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro. (byte-defop-compiler-1 track-mouse) +(defvar byte-compile--use-old-handlers t + "If nil, use new byte codes introduced in Emacs-24.4.") + (defun byte-compile-catch (form) (byte-compile-form (car (cdr form))) - (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)) + (if (not byte-compile--use-old-handlers) + (let ((endtag (byte-compile-make-tag))) + (byte-compile-goto 'byte-pushcatch endtag) + (byte-compile-body (cddr form) nil) + (byte-compile-out 'byte-pophandler) + (byte-compile-out-tag endtag)) + (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) (pcase (cddr form) (`(:fun-body ,f) - (byte-compile-form `(list (list 'funcall ,f)))) + (byte-compile-form + (if byte-compile--use-old-handlers `(list (list 'funcall ,f)) f))) (handlers - (byte-compile-push-constant - (byte-compile-top-level-body handlers t)))) + (if byte-compile--use-old-handlers + (byte-compile-push-constant + (byte-compile-top-level-body handlers t)) + (byte-compile-form `#'(lambda () ,@handlers))))) (byte-compile-out 'byte-unwind-protect 0) (byte-compile-form-do-effect (car (cdr form))) (byte-compile-out 'byte-unbind 1)) @@ -4031,6 +4091,11 @@ binding slots have been popped." (_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form)))))))) (defun byte-compile-condition-case (form) + (if byte-compile--use-old-handlers + (byte-compile-condition-case--old form) + (byte-compile-condition-case--new form))) + +(defun byte-compile-condition-case--old (form) (let* ((var (nth 1 form)) (fun-bodies (eq var :fun-body)) (byte-compile-bound-variables @@ -4081,6 +4146,62 @@ binding slots have been popped." (byte-compile-push-constant compiled-clauses))) (byte-compile-out 'byte-condition-case 0))) +(defun byte-compile-condition-case--new (form) + (let* ((var (nth 1 form)) + (body (nth 2 form)) + (depth byte-compile-depth) + (clauses (mapcar (lambda (clause) + (cons (byte-compile-make-tag) clause)) + (nthcdr 3 form))) + (endtag (byte-compile-make-tag))) + (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)) + + (dolist (clause (reverse clauses)) + (let ((condition (nth 1 clause))) + (unless (consp condition) (setq condition (list condition))) + (dolist (c condition) + (unless (and c (symbolp c)) + (byte-compile-warn + "`%S' is not a condition name (in condition-case)" c)) + ;; In reality, the `error-conditions' property is only required + ;; for the argument to `signal', not to `condition-case'. + ;;(unless (consp (get c 'error-conditions)) + ;; (byte-compile-warn + ;; "`%s' is not a known condition name (in condition-case)" + ;; c)) + ) + (byte-compile-push-constant condition)) + (byte-compile-goto 'byte-pushconditioncase (car clause))) + + (byte-compile-form body) ;; byte-compile--for-effect + (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) + (byte-compile-goto 'byte-goto endtag) + + (while clauses + (let ((clause (pop clauses)) + (byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile--lexical-environment + byte-compile--lexical-environment)) + (setq byte-compile-depth (1+ depth)) + (byte-compile-out-tag (pop clause)) + (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) + (cond + ((null var) (byte-compile-discard)) + (lexical-binding + (push (cons var (1- byte-compile-depth)) + byte-compile--lexical-environment)) + (t (byte-compile-dynamic-variable-bind var))) + (byte-compile-body (cdr clause)) ;; byte-compile--for-effect + (cond + ((null var) nil) + (lexical-binding (byte-compile-discard 1 'preserve-tos)) + (t (byte-compile-out 'byte-unbind 1))) + (byte-compile-goto 'byte-goto endtag))) + + (byte-compile-out-tag endtag))) (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) @@ -4165,7 +4286,7 @@ binding slots have been popped." (byte-compile-set-symbol-position 'autoload) (and (macroexp-const-p (nth 1 form)) (macroexp-const-p (nth 5 form)) - (eval (nth 5 form)) ; macro-p + (memq (eval (nth 5 form)) '(t macro)) ; macro-p (not (fboundp (eval (nth 1 form)))) (byte-compile-warn "The compiler ignores `autoload' except at top level. You should @@ -4221,6 +4342,12 @@ binding slots have been popped." lam)) (unless (byte-compile-file-form-defmumble name macro arglist body rest) + (when macro + (if (null fun) + (message "Macro %s unrecognized, won't work in file" name) + (message "Macro %s partly recognized, trying our luck" name) + (push (cons name (eval fun)) + byte-compile-macro-environment))) (byte-compile-keep-pending form)))) ;; We used to just do: (byte-compile-normal-call form) @@ -4243,32 +4370,12 @@ binding slots have been popped." (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote) (byte-compile-warning-enabled-p 'make-local)) (byte-compile-warn - "`make-variable-buffer-local' should be called at toplevel")) + "`make-variable-buffer-local' not called at toplevel")) (byte-compile-normal-call form)) (put 'make-variable-buffer-local 'byte-hunk-handler 'byte-compile-form-make-variable-buffer-local) (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 diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index ee84a9f69ba..40f1531e0f7 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -1,9 +1,9 @@ ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*- -;; Copyright (C) 2011-2013 Free Software Foundation, Inc. +;; Copyright (C) 2011-2014 Free Software Foundation, Inc. ;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp ;; Package: emacs @@ -55,7 +55,7 @@ ;; ;; 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 +;; var => (car-safe 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 @@ -79,9 +79,7 @@ ;; 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. +;; - new byte codes for unwind-protect so that closures aren't needed at all. ;; - a reference to a var that is known statically to always hold a constant ;; should be turned into a byte-constant rather than a byte-stack-ref. ;; Hmm... right, that's called constant propagation and could be done here, @@ -95,6 +93,7 @@ ;; (defmacro dlet (binders &rest body) ;; ;; Works in both lexical and non-lexical mode. +;; (declare (indent 1) (debug let)) ;; `(progn ;; ,@(mapcar (lambda (binder) ;; `(defvar ,(if (consp binder) (car binder) binder))) @@ -143,7 +142,19 @@ Returns a form where all lambdas don't have any free variables." ;; 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. + (prog1 (cconv-convert form nil nil) ; Env initially empty. + (cl-assert (null cconv-freevars-alist))))) + +;;;###autoload +(defun cconv-warnings-only (form) + "Add the warnings that closure conversion would encounter." + (let ((cconv-freevars-alist '()) + (cconv-lambda-candidates '()) + (cconv-captured+mutated '())) + ;; Analyze form - fill these variables with new information. + (cconv-analyse-form form '()) + ;; But don't perform the closure conversion. + form)) (defconst cconv--dummy-var (make-symbol "ignored")) @@ -199,9 +210,9 @@ Returns a form where all lambdas don't have any free variables." ;; 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 . ,_) + (`(car-safe ,iexp . ,_) (push iexp envector) - (push `(,fv . (car (internal-get-closed-var ,i))) new-env)) + (push `(,fv . (car-safe (internal-get-closed-var ,i))) new-env)) (_ (push exp envector) (push `(,fv . (internal-get-closed-var ,i)) new-env)))) @@ -212,7 +223,7 @@ Returns a form where all lambdas don't have any free variables." (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 . (car-safe ,arg)) new-env) (push `(,arg (list ,arg)) letbind))) (setq body-new (mapcar (lambda (form) @@ -242,7 +253,7 @@ 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 + (VAR . (car-safe 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. @@ -278,12 +289,15 @@ places where they originally did not directly appear." (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 + (var (if (not (consp binder)) + (prog1 binder (setq binder (list binder))) + (when (cddr binder) + (byte-compile-log-warning + (format "Malformed `%S' binding: %S" letsym 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 @@ -308,9 +322,9 @@ places where they originally did not directly appear." (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)))) + (if (and (eq 'car-safe (car-safe (cdr (assq fv env)))) (not (memq fv funargs))) - (push `(,fv . (car ,fv)) funcbody-env))) + (push `(,fv . (car-safe ,fv)) funcbody-env))) `(function (lambda ,funcvars . ,(mapcar (lambda (form) (cconv-convert @@ -320,7 +334,7 @@ places where they originally did not directly appear." ;; 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) + (push `(,var . (car-safe ,var)) new-env) `(list ,(cconv-convert value env extend))) ;; Normal default case. @@ -409,18 +423,42 @@ places where they originally did not directly appear." forms))) ;condition-case - (`(condition-case ,var ,protected-form . ,handlers) + ((and `(condition-case ,var ,protected-form . ,handlers) + (guard byte-compile--use-old-handlers)) (let ((newform (cconv--convert-function () (list protected-form) env form))) `(condition-case :fun-body ,newform - ,@(mapcar (lambda (handler) + ,@(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) + ; condition-case with new byte-codes. + (`(condition-case ,var ,protected-form . ,handlers) + `(condition-case ,var + ,(cconv-convert protected-form env extend) + ,@(let* ((cm (and var (member (cons (list var) form) + cconv-captured+mutated))) + (newenv + (cond (cm (cons `(,var . (car-save ,var)) env)) + ((assq var env) (cons `(,var) env)) + (t env)))) + (mapcar + (lambda (handler) + `(,(car handler) + ,@(let ((body + (mapcar (lambda (form) + (cconv-convert form newenv extend)) + (cdr handler)))) + (if (not cm) body + `((let ((,var (list ,var))) ,@body)))))) + handlers)))) + + (`(,(and head (or (and `catch (guard byte-compile--use-old-handlers)) + `unwind-protect)) + ,form . ,body) `(,head ,(cconv-convert form env extend) :fun-body ,(cconv--convert-function () body env form))) @@ -436,7 +474,7 @@ places where they originally did not directly appear." (value (cconv-convert (pop forms) env extend))) (push (pcase sym-new ((pred symbolp) `(setq ,sym-new ,value)) - (`(car ,iexp) `(setcar ,iexp ,value)) + (`(car-safe ,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. @@ -460,7 +498,7 @@ places where they originally did not directly appear." ,@(mapcar (lambda (fv) (let ((exp (or (cdr (assq fv env)) fv))) (pcase exp - (`(car ,iexp . ,_) iexp) + (`(car-safe ,iexp . ,_) iexp) (_ exp)))) fvs) ,@(mapcar (lambda (arg) @@ -479,7 +517,7 @@ places where they originally did not directly appear." (`(,func . ,forms) ;; First element is function or whatever function-like forms are: or, and, - ;; if, progn, prog1, prog2, while, until + ;; if, catch, progn, prog1, prog2, while, until `(,func . ,(mapcar (lambda (form) (cconv-convert form env extend)) forms))) @@ -489,6 +527,7 @@ places where they originally did not directly appear." (unless (fboundp 'byte-compile-not-lexical-var-p) ;; Only used to test the code in non-lexbind Emacs. (defalias 'byte-compile-not-lexical-var-p 'boundp)) +(defvar byte-compile-lexical-variables) (defun cconv--analyse-use (vardata form varkind) "Analyze the use of a variable. @@ -530,6 +569,7 @@ FORM is the parent form that binds this var." ;; outside of it. (envcopy (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env)) + (byte-compile-bound-variables byte-compile-bound-variables) (newenv envcopy)) ;; Push it before recursing, so cconv-freevars-alist contains entries in ;; the order they'll be used by closure-convert-rec. @@ -538,9 +578,11 @@ FORM is the parent form that binds this var." (cond ((byte-compile-not-lexical-var-p arg) (byte-compile-log-warning - (format "Argument %S is not a lexical variable" arg))) + (format "Lexical argument shadows the dynamic variable %S" + arg))) ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... (t (let ((varstruct (list arg nil nil nil nil))) + (cl-pushnew arg byte-compile-lexical-variables) (push (cons (list arg) (cdr varstruct)) newvars) (push varstruct newenv))))) (dolist (form body) ;Analyze body forms. @@ -579,6 +621,7 @@ and updates the data stored in ENV." (let ((orig-env env) (newvars nil) (var nil) + (byte-compile-bound-variables byte-compile-bound-variables) (value nil)) (dolist (binder binders) (if (not (consp binder)) @@ -592,6 +635,7 @@ and updates the data stored in ENV." (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) (unless (byte-compile-not-lexical-var-p var) + (cl-pushnew var byte-compile-lexical-variables) (let ((varstruct (list var nil nil nil nil))) (push (cons binder (cdr varstruct)) newvars) (push varstruct env)))) @@ -616,7 +660,8 @@ and updates the data stored in ENV." (`((lambda . ,_) . ,_) ; First element is lambda expression. (byte-compile-log-warning - "Use of deprecated ((lambda ...) ...) form" t :warning) + (format "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) + t :warning) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyse-form exp env))) @@ -627,16 +672,32 @@ and updates the data stored in ENV." (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote - (`(condition-case ,var ,protected-form . ,handlers) + ((and `(condition-case ,var ,protected-form . ,handlers) + (guard byte-compile--use-old-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). + ;; form and handlers in closures. (cconv--analyse-function () (list protected-form) env form) (dolist (handler handlers) - (cconv--analyse-function (if var (list var)) (cdr handler) env form))) + (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) + (`(condition-case ,var ,protected-form . ,handlers) + (cconv-analyse-form protected-form env) + (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) + (byte-compile-log-warning + (format "Lexical variable shadows the dynamic variable %S" var))) + (let* ((varstruct (list var nil nil nil nil))) + (if var (push varstruct env)) + (dolist (handler handlers) + (dolist (form (cdr handler)) + (cconv-analyse-form form env))) + (if var (cconv--analyse-use (cons (list var) (cdr varstruct)) + form "variable")))) + + ;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind. + (`(,(or (and `catch (guard byte-compile--use-old-handlers)) + `unwind-protect) + ,form . ,body) (cconv-analyse-form form env) (cconv--analyse-function () body env form)) @@ -645,6 +706,7 @@ and updates the data stored in ENV." (`(track-mouse . ,body) (cconv--analyse-function () body env form)) + (`(defvar ,var) (push var byte-compile-bound-variables)) (`(,(or `defconst `defvar) ,var ,value . ,_) (push var byte-compile-bound-variables) (cconv-analyse-form value env)) @@ -668,7 +730,9 @@ and updates the data stored in ENV." ;; seem worth the trouble. (dolist (form forms) (cconv-analyse-form form nil))) - (`(declare . ,_) nil) ;The args don't contain code. + ;; `declare' should now be macro-expanded away (and if they're not, we're + ;; in trouble because they *can* contain code nowadays). + ;; (`(declare . ,_) nil) ;The args don't contain code. (`(,_ . ,body-forms) ; First element is a function or whatever. (dolist (form body-forms) (cconv-analyse-form form env))) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index a259985df99..f84060e2630 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -1,6 +1,6 @@ ;;; chart.el --- Draw charts (bar charts, etc) -*- lexical-binding: t -*- -;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2013 Free +;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2014 Free ;; Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -86,10 +86,10 @@ Useful if new Emacs is used on B&W display.") :group 'eieio :type 'boolean) +(declare-function x-display-color-cells "xfns.c" (&optional terminal)) + (defvar chart-face-list - (if (if (fboundp 'display-color-p) - (display-color-p) - window-system) + (if (display-color-p) (let ((cl chart-face-color-list) (pl chart-face-pixmap-list) (faces ()) @@ -470,7 +470,7 @@ See `chart-sort-matchlist' for more details." (progn (chart-sort-matchlist s2 s1 pred) (setq s (oref s2 data))) - (error "Sorting of chart %s not supported" (object-name c)))) + (error "Sorting of chart %s not supported" (eieio-object-name c)))) (if (eq (oref c direction) 'horizontal) (oset (oref c y-axis) items s) (oset (oref c x-axis) items s) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 367db5240c9..19d61f0c6af 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-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2014 Free Software Foundation, Inc. ;; Author: Glenn Morris <rgm@gnu.org> ;; Keywords: lisp, tools, maint diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index b154e722707..4618e6118ec 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1,6 +1,6 @@ ;;; checkdoc.el --- check documentation strings for style requirements -;; Copyright (C) 1997-1998, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1997-1998, 2001-2014 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.6.2 @@ -186,7 +186,6 @@ (defcustom checkdoc-minor-mode-string " CDoc" "String to display in mode line when Checkdoc mode is enabled; nil for none." :type '(choice string (const :tag "None" nil)) - :group 'checkdoc :version "23.1") (defcustom checkdoc-autofix-flag 'semiautomatic @@ -197,7 +196,6 @@ made without asking unless the change is very-complex. If the value is `semiautomatic' or any other value, then simple fixes are made 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) @@ -207,7 +205,6 @@ The value `never' is the same as nil, never ask or change anything." "Non-nil means to \"bounce\" to auto-fix locations. Setting this to nil will silently make fixes that require no user interaction. See `checkdoc-autofix-flag' for auto-fixing details." - :group 'checkdoc :type 'boolean) (defcustom checkdoc-force-docstrings-flag t @@ -215,16 +212,14 @@ interaction. See `checkdoc-autofix-flag' for auto-fixing details." Style guide dictates that interactive functions MUST have documentation, and that it's good but not required practice to make non user visible items have doc strings." - :group 'checkdoc :type 'boolean) -;;;###autoload(put 'checkdoc-force-docstrings-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-force-docstrings-flag 'safe-local-variable #'booleanp) (defcustom checkdoc-force-history-flag nil "Non-nil means that files should have a History section or ChangeLog file. This helps document the evolution of, and recent changes to, the package." - :group 'checkdoc :type 'boolean) -;;;###autoload(put 'checkdoc-force-history-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-force-history-flag 'safe-local-variable #'booleanp) (defcustom checkdoc-permit-comma-termination-flag nil "Non-nil means the first line of a docstring may end with a comma. @@ -232,9 +227,8 @@ Ordinarily, a full sentence is required. This may be misleading when there is a substantial caveat to the one-line description -- the comma should be used when the first part could stand alone as a sentence, but it indicates that a modifying clause follows." - :group 'checkdoc :type 'boolean) -;;;###autoload(put 'checkdoc-permit-comma-termination-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-permit-comma-termination-flag 'safe-local-variable #'booleanp) (defcustom checkdoc-spellcheck-documentation-flag nil "Non-nil means run Ispell on text based on value. @@ -246,22 +240,22 @@ system. Possible values are: buffer - Spell-check when style checking the whole buffer interactive - Spell-check during any interactive check. t - Always spell-check" - :group 'checkdoc :type '(choice (const nil) (const defun) (const buffer) (const interactive) (const t))) +;;;###autoload(put 'checkdoc-spellcheck-documentation-flag 'safe-local-variable #'booleanp) (defvar checkdoc-ispell-lisp-words '("alist" "emacs" "etags" "keymap" "paren" "regexp" "sexp" "xemacs") "List of words that are correct when spell-checking Lisp documentation.") +;;;###autoload(put 'checkdoc-ispell-list-words 'safe-local-variable #'checkdoc-list-of-strings-p) (defcustom checkdoc-max-keyref-before-warn 10 "The number of \\ [command-to-keystroke] tokens allowed in a doc string. Any more than this and a warning is generated suggesting that the construct \\ {keymap} be used instead." - :group 'checkdoc :type 'integer) (defcustom checkdoc-arguments-in-order-flag t @@ -270,9 +264,8 @@ Setting this to nil will mean only checking that all the arguments appear in the proper form in the documentation, not that they are in the same order as they appear in the argument list. No mention is made in the style guide relating to order." - :group 'checkdoc :type 'boolean) -;;;###autoload(put 'checkdoc-arguments-in-order-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-arguments-in-order-flag 'safe-local-variable #'booleanp) (define-obsolete-variable-alias 'checkdoc-style-hooks 'checkdoc-style-functions "24.3") @@ -305,8 +298,8 @@ A search leaves the cursor in front of the parameter list.") "Non-nil means to attempt to check the voice of the doc string. This check keys off some words which are commonly misused. See the variable `checkdoc-common-verbs-wrong-voice' if you wish to add your own." - :group 'checkdoc :type 'boolean) +;;;###autoload(put 'checkdoc-verb-check-experimental-flag 'safe-local-variable #'booleanp) (defvar checkdoc-generate-compile-warnings-flag nil "Non-nil means generate warnings in a buffer for browsing. @@ -317,16 +310,15 @@ with a universal argument.") "A list of symbol names (strings) which also happen to make good words. These words are ignored when unquoted symbols are searched for. This should be set in an Emacs Lisp file's local variables." - :group 'checkdoc :type '(repeat (symbol :tag "Word"))) -;;;###autoload(put 'checkdoc-symbol-words 'safe-local-variable 'checkdoc-list-of-strings-p) +;;;###autoload(put 'checkdoc-symbol-words 'safe-local-variable #'checkdoc-list-of-strings-p) ;;;###autoload (defun checkdoc-list-of-strings-p (obj) ;; this is a function so it might be shared by checkdoc-proper-noun-list ;; and/or checkdoc-ispell-lisp-words in the future (and (listp obj) - (not (memq nil (mapcar 'stringp obj))))) + (not (memq nil (mapcar #'stringp obj))))) (defvar checkdoc-proper-noun-list '("ispell" "xemacs" "emacs" "lisp") @@ -340,9 +332,11 @@ This should be set in an Emacs Lisp file's local variables." (regexp-opt checkdoc-proper-noun-list t) "\\(\\_>\\|[.!?][ \t\n\"]\\)") "Regular expression derived from `checkdoc-proper-noun-regexp'.") +;;;###autoload(put 'checkdoc-proper-noun-regexp 'safe-local-variable 'stringp) (defvar checkdoc-common-verbs-regexp nil "Regular expression derived from `checkdoc-common-verbs-regexp'.") +;;;###autoload(put 'checkdoc-common-verbs-regexp 'safe-local-variable 'stringp) (defvar checkdoc-common-verbs-wrong-voice '(("adds" . "add") @@ -443,19 +437,19 @@ be re-created.") ;;; Compatibility ;; (defalias 'checkdoc-make-overlay - (if (featurep 'xemacs) 'make-extent 'make-overlay)) + (if (featurep 'xemacs) #'make-extent #'make-overlay)) (defalias 'checkdoc-overlay-put - (if (featurep 'xemacs) 'set-extent-property 'overlay-put)) + (if (featurep 'xemacs) #'set-extent-property #'overlay-put)) (defalias 'checkdoc-delete-overlay - (if (featurep 'xemacs) 'delete-extent 'delete-overlay)) + (if (featurep 'xemacs) #'delete-extent #'delete-overlay)) (defalias 'checkdoc-overlay-start - (if (featurep 'xemacs) 'extent-start 'overlay-start)) + (if (featurep 'xemacs) #'extent-start #'overlay-start)) (defalias 'checkdoc-overlay-end - (if (featurep 'xemacs) 'extent-end 'overlay-end)) + (if (featurep 'xemacs) #'extent-end #'overlay-end)) (defalias 'checkdoc-mode-line-update - (if (featurep 'xemacs) 'redraw-modeline 'force-mode-line-update)) + (if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update)) (defalias 'checkdoc-char= - (if (featurep 'xemacs) 'char= '=)) + (if (featurep 'xemacs) #'char= #'=)) ;;; User level commands ;; @@ -540,7 +534,7 @@ checkdoc status window instead of the usual behavior." ;; Due to a design flaw, this will never spell check ;; docstrings. (checkdoc-interactive-loop start-here showstatus - 'checkdoc-next-error) + #'checkdoc-next-error) ;; This is a workaround to perform spell checking. (checkdoc-interactive-ispell-loop start-here)))) @@ -560,7 +554,7 @@ checkdoc status window instead of the usual behavior." (prog1 ;; Due to a design flaw, this will never spell check messages. (checkdoc-interactive-loop start-here showstatus - 'checkdoc-next-message-error) + #'checkdoc-next-message-error) ;; This is a workaround to perform spell checking. (checkdoc-message-interactive-ispell-loop start-here)))) @@ -639,7 +633,7 @@ style." (goto-char (cdr (car err-list))) ;; `automatic-then-never' tells the autofix function ;; to only allow one fix to be automatic. The autofix - ;; function will then set the flag to 'never, allowing + ;; function will then set the flag to `never', allowing ;; the checker to return a different error. (let ((checkdoc-autofix-flag 'automatic-then-never) (fixed nil)) @@ -1004,7 +998,7 @@ Evaluation is done first so the form will be read before the documentation is checked. If there is a documentation error, then the display of what was evaluated will be overwritten by the diagnostic message." (interactive) - (call-interactively 'eval-defun) + (call-interactively #'eval-defun) (checkdoc-defun)) ;;;###autoload @@ -1046,85 +1040,86 @@ space at the end of each line." ;; ;;;###autoload -(defun checkdoc-ispell (&optional take-notes) +(defun checkdoc-ispell () "Check the style and spelling of everything interactively. Calls `checkdoc' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc'" +Prefix argument is the same as for `checkdoc'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc nil current-prefix-arg))) + (call-interactively #'checkdoc nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-current-buffer (&optional take-notes) +(defun checkdoc-ispell-current-buffer () "Check the style and spelling of the current buffer. Calls `checkdoc-current-buffer' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-current-buffer'" +Prefix argument is the same as for `checkdoc-current-buffer'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-current-buffer nil current-prefix-arg))) + (call-interactively #'checkdoc-current-buffer nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-interactive (&optional take-notes) +(defun checkdoc-ispell-interactive () "Check the style and spelling of the current buffer interactively. Calls `checkdoc-interactive' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-interactive'" +Prefix argument is the same as for `checkdoc-interactive'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-interactive nil current-prefix-arg))) + (call-interactively #'checkdoc-interactive nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-message-interactive (&optional take-notes) +(defun checkdoc-ispell-message-interactive () "Check the style and spelling of message text interactively. Calls `checkdoc-message-interactive' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-message-interactive'" +Prefix argument is the same as for `checkdoc-message-interactive'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-message-interactive nil current-prefix-arg))) + (call-interactively #'checkdoc-message-interactive + nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-message-text (&optional take-notes) +(defun checkdoc-ispell-message-text () "Check the style and spelling of message text interactively. Calls `checkdoc-message-text' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-message-text'" +Prefix argument is the same as for `checkdoc-message-text'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-message-text nil current-prefix-arg))) + (call-interactively #'checkdoc-message-text nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-start (&optional take-notes) +(defun checkdoc-ispell-start () "Check the style and spelling of the current buffer. Calls `checkdoc-start' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-start'" +Prefix argument is the same as for `checkdoc-start'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-start nil current-prefix-arg))) + (call-interactively #'checkdoc-start nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-continue (&optional take-notes) +(defun checkdoc-ispell-continue () "Check the style and spelling of the current buffer after point. Calls `checkdoc-continue' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-continue'" +Prefix argument is the same as for `checkdoc-continue'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-continue nil current-prefix-arg))) + (call-interactively #'checkdoc-continue nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-comments (&optional take-notes) +(defun checkdoc-ispell-comments () "Check the style and spelling of the current buffer's comments. Calls `checkdoc-comments' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-comments'" +Prefix argument is the same as for `checkdoc-comments'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-comments nil current-prefix-arg))) + (call-interactively #'checkdoc-comments nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-defun (&optional take-notes) +(defun checkdoc-ispell-defun () "Check the style and spelling of the current defun with Ispell. Calls `checkdoc-defun' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-defun'" +Prefix argument is the same as for `checkdoc-defun'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-defun nil current-prefix-arg))) + (call-interactively #'checkdoc-defun nil current-prefix-arg))) ;;; Error Management ;; @@ -1254,10 +1249,10 @@ checking of documentation strings. (defsubst checkdoc-run-hooks (hookvar &rest args) "Run hooks in HOOKVAR with ARGS." (if (fboundp 'run-hook-with-args-until-success) - (apply 'run-hook-with-args-until-success hookvar args) + (apply #'run-hook-with-args-until-success hookvar args) ;; This method was similar to above. We ignore the warning ;; since we will use the above for future Emacs versions - (apply 'run-hook-with-args hookvar args))) + (apply #'run-hook-with-args hookvar args))) (defsubst checkdoc-create-common-verbs-regexp () "Rebuild the contents of `checkdoc-common-verbs-regexp'." @@ -2066,7 +2061,8 @@ If the offending word is in a piece of quoted text, then it is skipped." ;;; Ispell engine ;; -(eval-when-compile (require 'ispell)) +(defvar ispell-process) +(declare-function ispell-buffer-local-words "ispell" ()) (defun checkdoc-ispell-init () "Initialize Ispell process (default version) with Lisp words. @@ -2074,19 +2070,14 @@ The words used are from `checkdoc-ispell-lisp-words'. If `ispell' cannot be loaded, then set `checkdoc-spellcheck-documentation-flag' to nil." (require 'ispell) - (if (not (symbol-value 'ispell-process)) ;Silence byteCompiler - (condition-case nil - (progn - (ispell-buffer-local-words) - ;; This code copied in part from ispell.el Emacs 19.34 - (let ((w checkdoc-ispell-lisp-words)) - (while w - (process-send-string - ;; Silence byte compiler - (symbol-value 'ispell-process) - (concat "@" (car w) "\n")) - (setq w (cdr w))))) - (error (setq checkdoc-spellcheck-documentation-flag nil))))) + (unless ispell-process + (condition-case nil + (progn + (ispell-buffer-local-words) + ;; This code copied in part from ispell.el Emacs 19.34 + (dolist (w checkdoc-ispell-lisp-words) + (process-send-string ispell-process (concat "@" w "\n")))) + (error (setq checkdoc-spellcheck-documentation-flag nil))))) (defun checkdoc-ispell-docstring-engine (end) "Run the Ispell tools on the doc string between point and END. @@ -2187,14 +2178,13 @@ News agents may remove it" ;;; Comment checking engine ;; -(eval-when-compile - ;; We must load this to: - ;; a) get symbols for compile and - ;; b) determine if we have lm-history symbol which doesn't always exist - (require 'lisp-mnt)) - (defvar generate-autoload-cookie) +(eval-when-compile (require 'lisp-mnt)) ; expand silly defsubsts +(declare-function lm-summary "lisp-mnt" (&optional file)) +(declare-function lm-section-start "lisp-mnt" (header &optional after)) +(declare-function lm-section-end "lisp-mnt" (header)) + (defun checkdoc-file-comments-engine () "Return a message list if this file does not match the Emacs standard. This checks for style only, such as the first line, Commentary:, @@ -2203,8 +2193,8 @@ Code:, and others referenced in the style guide." nil (require 'lisp-mnt) ;; Old XEmacs don't have `lm-commentary-mark' - (if (and (not (fboundp 'lm-commentary-mark)) (boundp 'lm-commentary)) - (defalias 'lm-commentary-mark 'lm-commentary))) + (if (and (not (fboundp 'lm-commentary-mark)) (fboundp 'lm-commentary)) + (defalias 'lm-commentary-mark #'lm-commentary))) (save-excursion (let* ((f1 (file-name-nondirectory (buffer-file-name))) (fn (file-name-sans-extension f1)) @@ -2265,8 +2255,7 @@ Code:, and others referenced in the style guide." (if (or (not checkdoc-force-history-flag) (file-exists-p "ChangeLog") (file-exists-p "../ChangeLog") - (let ((fn 'lm-history-mark)) ;bestill byte-compiler - (and (fboundp fn) (funcall fn)))) + (and (fboundp 'lm-history-mark) (funcall #'lm-history-mark))) nil (progn (goto-char (or (lm-commentary-mark) (point-min))) @@ -2590,10 +2579,10 @@ This function will not modify `match-data'." (define-derived-mode checkdoc-output-mode compilation-mode "Checkdoc" "Set up the major mode for the buffer containing the list of errors." - (set (make-local-variable 'compilation-error-regexp-alist) - checkdoc-output-error-regex-alist) - (set (make-local-variable 'compilation-mode-font-lock-keywords) - checkdoc-output-font-lock-keywords)) + (setq-local compilation-error-regexp-alist + checkdoc-output-error-regex-alist) + (setq-local compilation-mode-font-lock-keywords + checkdoc-output-font-lock-keywords)) (defun checkdoc-buffer-label () "The name to use for a checkdoc buffer in the error list." @@ -2625,7 +2614,7 @@ function called to create the messages." (with-current-buffer (get-buffer checkdoc-diagnostic-buffer) (goto-char (point-max)) (let ((inhibit-read-only t)) - (apply 'insert text))))) + (apply #'insert text))))) (defun checkdoc-show-diagnostics () "Display the checkdoc diagnostic buffer in a temporary window." diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 34892bf2fef..9b28289e0b9 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -1,6 +1,6 @@ ;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2000-2014 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Keywords: extensions @@ -597,8 +597,11 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (macroexp-let2 nil d def (funcall do `(cl-getf ,getter ,k ,d) (lambda (v) - (funcall setter - `(cl--set-getf ,getter ,k ,v)))))))))) + (macroexp-let2 nil val v + `(progn + ,(funcall setter + `(cl--set-getf ,getter ,k ,val)) + ,val)))))))))) (setplist '--cl-getf-symbol-- plist) (or (get '--cl-getf-symbol-- tag) ;; Originally we called cl-get here, diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 599cf3ac345..6c62ce5c830 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -1,10 +1,10 @@ ;;; cl-indent.el --- enhanced lisp-indent mode -;; Copyright (C) 1987, 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 1987, 2000-2014 Free Software Foundation, Inc. ;; Author: Richard Mlynarik <mly@eddie.mit.edu> ;; Created: July 1987 -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, tools ;; Package: emacs @@ -756,6 +756,7 @@ optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\ (when 1) (with-accessors . multiple-value-bind) (with-condition-restarts . multiple-value-bind) + (with-compilation-unit (&lambda &body)) (with-output-to-string (4 2)) (with-slots . multiple-value-bind) (with-standard-io-syntax (2))))) @@ -809,4 +810,6 @@ optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\ ;(put 'defclass 'common-lisp-indent-function '((&whole 2 &rest (&whole 2 &rest 1) &rest (&whole 2 &rest 1))) ;(put 'defgeneric 'common-lisp-indent-function 'defun) +(provide 'cl-indent) + ;;; cl-indent.el ends here diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index f3bf70b0190..219d76f85d1 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -1,6 +1,6 @@ ;;; cl-lib.el --- Common Lisp extensions for Emacs -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2014 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 1.0 @@ -36,13 +36,6 @@ ;; 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): @@ -156,8 +149,8 @@ an element already on the list. ;; earlier and should have triggered them already. (with-no-warnings ,place) (setq ,place (cons ,var ,place)))) - (list 'setq place (cl-list* 'cl-adjoin x place keys))) - (cl-list* 'cl-callf2 'cl-adjoin x place keys))) + `(setq ,place (cl-adjoin ,x ,place ,@keys))) + `(cl-callf2 cl-adjoin ,x ,place ,@keys))) (defun cl--set-elt (seq n val) (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) @@ -721,6 +714,9 @@ If ALIST is non-nil, the new pairs are prepended to it." ;;;###autoload (progn + ;; The `assert' macro from the cl package signals + ;; `cl-assertion-failed' at runtime so always define it. + (define-error 'cl-assertion-failed (purecopy "Assertion failed")) ;; 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. @@ -732,9 +728,10 @@ If ALIST is non-nil, the new pairs are prepended to it." (put 'cl-defsubst 'doc-string-elt 3) (put 'cl-defstruct 'doc-string-elt 2)) -(load "cl-loaddefs" nil 'quiet) - (provide 'cl-lib) +(or (load "cl-loaddefs" 'noerror 'quiet) + ;; When bootstrapping, cl-loaddefs hasn't been built yet! + (require 'cl-macs)) ;; Local variables: ;; byte-compile-dynamic: t diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el deleted file mode 100644 index 8ab2abec67e..00000000000 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ /dev/null @@ -1,1264 +0,0 @@ -;;; cl-loaddefs.el --- automatically extracted autoloads -;; -;;; Code: - - -;;;### (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" "c5730f2a706cb1efc5fec0a790d3ca72") -;;; Generated autoloads from cl-extra.el - -(autoload 'cl-coerce "cl-extra" "\ -Coerce OBJECT to type TYPE. -TYPE is a Common Lisp type specifier. - -\(fn OBJECT TYPE)" nil nil) - -(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 -strings case-insensitively. - -\(fn X Y)" nil nil) - -(autoload 'cl--mapcar-many "cl-extra" "\ - - -\(fn CL-FUNC CL-SEQS)" nil nil) - -(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 'cl-maplist "cl-extra" "\ -Map FUNCTION to each sublist of LIST or LISTs. -Like `cl-mapcar', except applies to lists and their cdr's rather than to -the elements themselves. - -\(fn FUNCTION LIST...)" nil nil) - -(autoload 'cl-mapc "cl-extra" "\ -Like `cl-mapcar', but does not accumulate values returned by the function. - -\(fn FUNCTION SEQUENCE...)" nil nil) - -(autoload 'cl-mapl "cl-extra" "\ -Like `cl-maplist', but does not accumulate values returned by the function. - -\(fn FUNCTION LIST...)" nil nil) - -(autoload 'cl-mapcan "cl-extra" "\ -Like `cl-mapcar', but nconc's together the values returned by the function. - -\(fn FUNCTION SEQUENCE...)" nil nil) - -(autoload 'cl-mapcon "cl-extra" "\ -Like `cl-maplist', but nconc's together the values returned by the function. - -\(fn FUNCTION LIST...)" nil nil) - -(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 'cl-every "cl-extra" "\ -Return true if PREDICATE is true of every element of SEQ or SEQs. - -\(fn PREDICATE SEQ...)" nil nil) - -(autoload 'cl-notany "cl-extra" "\ -Return true if PREDICATE is false of every element of SEQ or SEQs. - -\(fn PREDICATE SEQ...)" nil nil) - -(autoload 'cl-notevery "cl-extra" "\ -Return true if PREDICATE is false of some element of SEQ or SEQs. - -\(fn PREDICATE SEQ...)" nil nil) - -(autoload 'cl--map-keymap-recursively "cl-extra" "\ - - -\(fn CL-FUNC-REC CL-MAP &optional CL-BASE)" nil nil) - -(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" "\ - - -\(fn CL-FUNC &optional CL-BUFFER CL-START CL-END CL-ARG)" nil nil) - -(autoload 'cl--set-frame-visible-p "cl-extra" "\ - - -\(fn FRAME VAL)" nil nil) - -(autoload 'cl-gcd "cl-extra" "\ -Return the greatest common divisor of the arguments. - -\(fn &rest ARGS)" nil nil) - -(autoload 'cl-lcm "cl-extra" "\ -Return the least common multiple of the arguments. - -\(fn &rest ARGS)" nil nil) - -(autoload 'cl-isqrt "cl-extra" "\ -Return the integer square root of the argument. - -\(fn X)" nil nil) - -(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 '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 '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 '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 'cl-mod "cl-extra" "\ -The remainder of X divided by Y, with the same sign as Y. - -\(fn X Y)" nil nil) - -(autoload 'cl-rem "cl-extra" "\ -The remainder of X divided by Y, with the same sign as X. - -\(fn X Y)" nil nil) - -(autoload 'cl-signum "cl-extra" "\ -Return 1 if X is positive, -1 if negative, 0 if zero. - -\(fn X)" nil nil) - -(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 '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 '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" "\ -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 '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 'cl-concatenate "cl-extra" "\ -Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. - -\(fn TYPE SEQUENCE...)" nil nil) - -(autoload 'cl-revappend "cl-extra" "\ -Equivalent to (append (reverse X) Y). - -\(fn X Y)" nil nil) - -(autoload 'cl-nreconc "cl-extra" "\ -Equivalent to (nconc (nreverse X) Y). - -\(fn X Y)" nil nil) - -(autoload 'cl-list-length "cl-extra" "\ -Return the length of list X. Return nil if list is circular. - -\(fn X)" nil nil) - -(autoload 'cl-tailp "cl-extra" "\ -Return true if SUBLIST is a tail of LIST. - -\(fn SUBLIST LIST)" nil nil) - -(autoload 'cl-get "cl-extra" "\ -Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. - -\(fn SYMBOL PROPNAME &optional DEFAULT)" nil nil) - -(eval-and-compile (put 'cl-get 'compiler-macro #'cl--compiler-macro-get)) - -(autoload 'cl-getf "cl-extra" "\ -Search PROPLIST for property PROPNAME; return its value or DEFAULT. -PROPLIST is a list of the sort returned by `symbol-plist'. - -\(fn PROPLIST PROPNAME &optional DEFAULT)" nil nil) - -(autoload 'cl--set-getf "cl-extra" "\ - - -\(fn PLIST TAG VAL)" nil nil) - -(autoload 'cl--do-remf "cl-extra" "\ - - -\(fn PLIST TAG)" nil nil) - -(autoload 'cl-remprop "cl-extra" "\ -Remove from SYMBOL's plist the property PROPNAME and its value. - -\(fn SYMBOL PROPNAME)" nil nil) - -(autoload 'cl-prettyexpand "cl-extra" "\ -Expand macros in FORM and insert the pretty-printed result. -Optional argument FULL non-nil means to expand all macros, -including `cl-block' and `cl-eval-when'. - -\(fn FORM &optional FULL)" nil nil) - -;;;*** - -;;;### (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-tagbody cl-dotimes cl-dolist -;;;;;; cl-do* cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase -;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when -;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp -;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*) -;;;;;; "cl-macs" "cl-macs.el" "8a90c81a400a2846e7b4c3da07626d94") -;;; Generated autoloads from cl-macs.el - -(autoload 'cl--compiler-macro-list* "cl-macs" "\ - - -\(fn FORM ARG &rest OTHERS)" nil nil) - -(autoload 'cl--compiler-macro-cXXr "cl-macs" "\ - - -\(fn FORM X)" nil nil) - -(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 '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 '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 (cl-block NAME ...). - -\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil t) - -(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 (cl-block NAME ...). - -\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil t) - -(put 'cl-defmacro 'doc-string-elt '3) - -(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 t) - -(autoload 'cl-destructuring-bind "cl-macs" "\ -Bind the variables in ARGS to the result of EXPR and execute BODY. - -\(fn ARGS EXPR &rest BODY)" nil t) - -(put 'cl-destructuring-bind 'lisp-indent-function '2) - -(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 t) - -(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 t) - -(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, 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 t) - -(put 'cl-case 'lisp-indent-function '1) - -(autoload 'cl-ecase "cl-macs" "\ -Like `cl-case', but error if no case fits. -`otherwise'-clauses are not allowed. - -\(fn EXPR (KEYLIST BODY...)...)" nil t) - -(put 'cl-ecase 'lisp-indent-function '1) - -(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, -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 t) - -(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 t) - -(put 'cl-etypecase 'lisp-indent-function '1) - -(autoload 'cl-block "cl-macs" "\ -Define a lexically-scoped block named NAME. -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. - -\(fn NAME &rest BODY)" nil t) - -(put 'cl-block 'lisp-indent-function '1) - -(autoload 'cl-return "cl-macs" "\ -Return from the block named nil. -This is equivalent to `(cl-return-from nil RESULT)'. - -\(fn &optional RESULT)" nil t) - -(autoload 'cl-return-from "cl-macs" "\ -Return from the block named NAME. -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 t) - -(put 'cl-return-from 'lisp-indent-function '1) - -(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, - for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, - for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND, - always COND, never COND, thereis COND, collect EXPR into VAR, - append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR, - count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR, - if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR, - finally return EXPR, named NAME. - -\(fn CLAUSE...)" nil t) - -(autoload 'cl-do "cl-macs" "\ -The Common Lisp `do' loop. - -\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil t) - -(put 'cl-do 'lisp-indent-function '2) - -(autoload 'cl-do* "cl-macs" "\ -The Common Lisp `do*' loop. - -\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil t) - -(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) - -(put 'cl-dolist 'lisp-indent-function '1) - -(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 t) - -(put 'cl-dotimes 'lisp-indent-function '1) - -(autoload 'cl-tagbody "cl-macs" "\ -Execute statements while providing for control transfers to labels. -Each element of LABELS-OR-STMTS can be either a label (integer or symbol) -or a `cons' cell, in which case it's taken to be a statement. -This distinction is made before performing macroexpansion. -Statements are executed in sequence left to right, discarding any return value, -stopping only when reaching the end of LABELS-OR-STMTS. -Any statement can transfer control at any time to the statements that follow -one of the labels with the special form (go LABEL). -Labels have lexical scope and dynamic extent. - -\(fn &rest LABELS-OR-STMTS)" nil t) - -(autoload 'cl-do-symbols "cl-macs" "\ -Loop over all symbols. -Evaluate BODY with VAR bound to each interned symbol, or to each symbol -from OBARRAY. - -\(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. - -\(fn (VAR [RESULT]) BODY...)" nil t) - -(put 'cl-do-all-symbols 'lisp-indent-function '1) - -(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 t) - -(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 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 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) - -(put 'cl-flet 'lisp-indent-function '1) - -(autoload 'cl-flet* "cl-macs" "\ -Make local function definitions. -Like `cl-flet' but the definitions can refer to previous ones. - -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t) - -(put 'cl-flet* 'lisp-indent-function '1) - -(autoload 'cl-labels "cl-macs" "\ -Make temporary function bindings. -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) - -(put 'cl-labels 'lisp-indent-function '1) - -(autoload 'cl-macrolet "cl-macs" "\ -Make temporary macro definitions. -This is like `cl-flet', but for macros instead of functions. - -\(fn ((NAME ARGLIST BODY...) ...) FORM...)" nil t) - -(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 t) - -(put 'cl-symbol-macrolet 'lisp-indent-function '1) - -(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 `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 t) - -(put 'cl-multiple-value-bind 'lisp-indent-function '2) - -(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 -`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)" nil t) - -(put 'cl-multiple-value-setq 'lisp-indent-function '1) - -(autoload 'cl-locally "cl-macs" "\ -Equivalent to `progn'. - -\(fn &rest BODY)" nil t) - -(autoload 'cl-the "cl-macs" "\ -At present this ignores _TYPE and is simply equivalent to FORM. - -\(fn TYPE FORM)" nil t) - -(put 'cl-the 'lisp-indent-function '1) - -(autoload 'cl-declare "cl-macs" "\ -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. - -\(fn &rest SPECS)" nil t) - -(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 t) - -(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 t) - -(autoload 'cl-shiftf "cl-macs" "\ -Shift left among PLACEs. -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 t) - -(autoload 'cl-rotatef "cl-macs" "\ -Rotate left among PLACEs. -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 t) - -(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. - -\(fn ((PLACE VALUE) ...) BODY...)" nil t) - -(put 'cl-letf 'lisp-indent-function '1) - -(autoload 'cl-letf* "cl-macs" "\ -Temporarily bind to PLACEs. -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 BINDINGS &rest BODY)" nil t) - -(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 &rest ARGS)" nil t) - -(put 'cl-callf 'lisp-indent-function '2) - -(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. - -\(fn FUNC ARG1 PLACE ARGS...)" nil t) - -(put 'cl-callf2 'lisp-indent-function '3) - -(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' -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) 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 t) - -(put 'cl-defstruct 'doc-string-elt '2) - -(put 'cl-defstruct 'lisp-indent-function '1) - -(autoload 'cl-deftype "cl-macs" "\ -Define NAME as a new data type. -The type name can then be used in `cl-typecase', `cl-check-type', etc. - -\(fn NAME ARGLIST &rest BODY)" nil t) - -(put 'cl-deftype 'doc-string-elt '3) - -(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 '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 t) - -(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 t) - -(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 -for optimizing the way calls to FUNC are compiled; the form returned by -BODY should do the same thing as a call to the normal function called -FUNC, though possibly more efficiently. Note that, like regular macros, -compiler macros are expanded repeatedly until no further expansions are -possible. Unlike regular macros, BODY can decide to \"punt\" and leave the -original function call alone by declaring an initial `&whole foo' parameter -and then returning foo. - -\(fn FUNC ARGS &rest BODY)" nil t) - -(autoload 'cl-compiler-macroexpand "cl-macs" "\ -Like `macroexpand', but for compiler macros. -Expands FORM repeatedly until no further expansion is possible. -Returns FORM unchanged if it has no compiler macro, or if it has a -macro that returns its `&whole' argument. - -\(fn FORM)" nil nil) - -(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 (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 FORM A LIST &rest KEYS)" nil nil) - -;;;*** - -;;;### (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" "51a70dea9cbc225165a50135956609aa") -;;; Generated autoloads from cl-seq.el - -(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 'cl-fill "cl-seq" "\ -Fill the elements of SEQ with ITEM. - -Keywords supported: :start :end - -\(fn SEQ ITEM [KEYWORD VALUE]...)" nil nil) - -(autoload 'cl-replace "cl-seq" "\ -Replace the elements of SEQ1 with the elements of SEQ2. -SEQ1 is destructively modified, then returned. - -Keywords supported: :start1 :end1 :start2 :end2 - -\(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :test :test-not :key :count :start :end :from-end - -\(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key :count :start :end :from-end - -\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key :count :start :end :from-end - -\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :test :test-not :key :count :start :end :from-end - -\(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key :count :start :end :from-end - -\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key :count :start :end :from-end - -\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(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 '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 '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. - -Keywords supported: :test :test-not :key :count :start :end :from-end - -\(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key :count :start :end :from-end - -\(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key :count :start :end :from-end - -\(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(autoload 'cl-nsubstitute "cl-seq" "\ -Substitute NEW for OLD in SEQ. -This is a destructive function; it reuses the storage of SEQ whenever possible. - -Keywords supported: :test :test-not :key :count :start :end :from-end - -\(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key :count :start :end :from-end - -\(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key :count :start :end :from-end - -\(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(autoload 'cl-find "cl-seq" "\ -Find the first occurrence of ITEM in SEQ. -Return the matching ITEM, or nil if not found. - -Keywords supported: :test :test-not :key :start :end :from-end - -\(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) - -(autoload 'cl-find-if "cl-seq" "\ -Find the first item satisfying PREDICATE in SEQ. -Return the matching item, or nil if not found. - -Keywords supported: :key :start :end :from-end - -\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key :start :end :from-end - -\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :test :test-not :key :start :end :from-end - -\(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key :start :end :from-end - -\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key :start :end :from-end - -\(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) - -(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 '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 '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 '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. - -Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end - -\(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end - -\(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key - -\(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key - -\(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key - -\(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)" nil nil) - -(autoload 'cl-member "cl-seq" "\ -Find the first occurrence of ITEM in LIST. -Return the sublist of LIST whose car is ITEM. - -Keywords supported: :test :test-not :key - -\(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) - -(eval-and-compile (put 'cl-member 'compiler-macro #'cl--compiler-macro-member)) - -(autoload 'cl-member-if "cl-seq" "\ -Find the first item satisfying PREDICATE in LIST. -Return the sublist of LIST whose car matches. - -Keywords supported: :key - -\(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) - -(autoload 'cl-member-if-not "cl-seq" "\ -Find the first item not satisfying PREDICATE in LIST. -Return the sublist of LIST whose car matches. - -Keywords supported: :key - -\(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) - -(autoload 'cl--adjoin "cl-seq" "\ - - -\(fn CL-ITEM CL-LIST &rest CL-KEYS)" nil nil) - -(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) - -(eval-and-compile (put 'cl-assoc 'compiler-macro #'cl--compiler-macro-assoc)) - -(autoload 'cl-assoc-if "cl-seq" "\ -Find the first item whose car satisfies PREDICATE in LIST. - -Keywords supported: :key - -\(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) - -(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 '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 '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 '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 '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 -to avoid corrupting the original LIST1 and LIST2. - -Keywords supported: :test :test-not :key - -\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) - -(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 -whenever possible. - -Keywords supported: :test :test-not :key - -\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) - -(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 -to avoid corrupting the original LIST1 and LIST2. - -Keywords supported: :test :test-not :key - -\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) - -(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 -whenever possible. - -Keywords supported: :test :test-not :key - -\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) - -(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 -to avoid corrupting the original LIST1 and LIST2. - -Keywords supported: :test :test-not :key - -\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) - -(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 -whenever possible. - -Keywords supported: :test :test-not :key - -\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) - -(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 -to avoid corrupting the original LIST1 and LIST2. - -Keywords supported: :test :test-not :key - -\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) - -(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 -whenever possible. - -Keywords supported: :test :test-not :key - -\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :test :test-not :key - -\(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key - -\(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :key - -\(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) - -(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'). - -Keywords supported: :test :test-not :key - -\(fn NEW OLD TREE [KEYWORD VALUE]...)" nil nil) - -(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'). - -Keywords supported: :key - -\(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) - -(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'). - -Keywords supported: :key - -\(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) - -(autoload 'cl-sublis "cl-seq" "\ -Perform substitutions indicated by ALIST in TREE (non-destructively). -Return a copy of TREE with all matching elements replaced. - -Keywords supported: :test :test-not :key - -\(fn ALIST TREE [KEYWORD VALUE]...)" nil nil) - -(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'. - -Keywords supported: :test :test-not :key - -\(fn ALIST TREE [KEYWORD VALUE]...)" nil nil) - -(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. - -Keywords supported: :test :test-not :key - -\(fn TREE1 TREE2 [KEYWORD VALUE]...)" nil nil) - -;;;*** - -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; coding: utf-8 -;; End: -;;; cl-loaddefs.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index e9cc200baaa..b1861cf7dfa 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,9 +1,9 @@ ;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t; coding: utf-8 -*- -;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2014 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 +;; Old-Version: 2.02 ;; Keywords: extensions ;; Package: emacs @@ -209,6 +209,8 @@ The name is made by appending a number to PREFIX, default \"G\"." (def-edebug-spec cl-&key-arg (&or ([&or (symbolp arg) arg] &optional def-form arg) arg)) +(def-edebug-spec cl-type-spec sexp) + (defconst cl--lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) @@ -584,7 +586,7 @@ 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...)" - (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body))) + (declare (indent 1) (debug (sexp 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))) @@ -616,7 +618,7 @@ The result of the body appears to the compiler as a quoted constant." (declare (debug (form &optional sexp))) (if (cl--compiling-file) (let* ((temp (cl-gentemp "--cl-load-time--")) - (set `(set ',temp ,form))) + (set `(setq ,temp ,form))) (if (and (fboundp 'byte-compile-file-form-defmumble) (boundp 'this-kind) (boundp 'that-one)) (fset 'byte-compile-file-form @@ -754,28 +756,54 @@ This is compatible with Common Lisp, but note that `defun' and ;;; The "cl-loop" macro. (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-bindings) (defvar cl--loop-body) +(defvar cl--loop-finally) +(defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop? (defvar cl--loop-first-flag) -(defvar cl--loop-initially) (defvar cl--loop-map-form) (defvar cl--loop-name) +(defvar cl--loop-initially) (defvar cl--loop-iterator-function) +(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) +(defun cl--loop-set-iterator-function (kind iterator) + (if cl--loop-iterator-function + ;; FIXME: Of course, we could make it work, but why bother. + (error "Iteration on %S does not support this combination" kind) + (setq cl--loop-iterator-function iterator))) + ;;;###autoload (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, - for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, - for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND, - always COND, never COND, thereis COND, collect EXPR into VAR, - append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR, - count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR, - if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...], - do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR, - finally return EXPR, named NAME. +Valid clauses include: + For clauses: + for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2 by EXPR3 + for VAR = EXPR1 then EXPR2 + for VAR in/on/in-ref LIST by FUNC + for VAR across/across-ref ARRAY + for VAR being: + the elements of/of-ref SEQUENCE [using (index VAR2)] + the symbols [of OBARRAY] + the hash-keys/hash-values of HASH-TABLE [using (hash-values/hash-keys V2)] + the key-codes/key-bindings/key-seqs of KEYMAP [using (key-bindings VAR2)] + the overlays/intervals [of BUFFER] [from POS1] [to POS2] + the frames/buffers + the windows [of FRAME] + Iteration clauses: + repeat INTEGER + while/until/always/never/thereis CONDITION + Accumulation clauses: + collect/append/nconc/concat/vconcat/count/sum/maximize/minimize FORM + [into VAR] + Miscellaneous clauses: + with VAR = INIT + if/when/unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...] + named NAME + initially/finally [do] EXPRS... + do EXPRS... + [finally] return EXPR + +For more details, see Info node `(cl)Loop Facility'. \(fn CLAUSE...)" (declare (debug (&rest &or @@ -797,13 +825,35 @@ Valid clauses are: (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-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)) + (cl--loop-iterator-function nil) (cl--loop-first-flag nil) + (cl--loop-symbol-macs nil)) + ;; Here is more or less how those dynbind vars are used after looping + ;; over cl--parse-loop-clause: + ;; + ;; (cl-block ,cl--loop-name + ;; (cl-symbol-macrolet ,cl--loop-symbol-macs + ;; (foldl #'cl--loop-let + ;; `((,cl--loop-result-var) + ;; ((,cl--loop-first-flag t)) + ;; ((,cl--loop-finish-flag t)) + ;; ,@cl--loop-bindings) + ;; ,@(nreverse cl--loop-initially) + ;; (while ;(well: cl--loop-iterator-function) + ;; ,(car (cl--loop-build-ands (nreverse cl--loop-body))) + ;; ,@(cadr (cl--loop-build-ands (nreverse cl--loop-body))) + ;; ,@(nreverse cl--loop-steps) + ;; (setq ,cl--loop-first-flag nil)) + ;; (if (not ,cl--loop-finish-flag) ;FIXME: Why `if' vs `progn'? + ;; ,cl--loop-result-var + ;; ,@(nreverse cl--loop-finally) + ;; ,(or cl--loop-result-explicit + ;; cl--loop-result))))) + ;; (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)) @@ -819,15 +869,15 @@ Valid clauses are: (while-body (nconc (cadr ands) (nreverse cl--loop-steps))) (body (append (nreverse cl--loop-initially) - (list (if cl--loop-map-form + (list (if cl--loop-iterator-function `(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)) + ,(funcall cl--loop-iterator-function + (if (eq (car ands) t) while-body + (cons `(or ,(car ands) + (cl-return-from + --cl-finish-- + nil)) + while-body)))) `(while ,(car ands) ,@while-body))) (if cl--loop-finish-flag (if (equal epilogue '(nil)) (list cl--loop-result-var) @@ -1196,15 +1246,18 @@ Valid clauses are: (make-symbol "--cl-var--")))) (if (memq word '(hash-value hash-values)) (setq var (prog1 other (setq other var)))) - (setq cl--loop-map-form - `(maphash (lambda (,var ,other) . --cl-map) ,table)))) + (cl--loop-set-iterator-function + 'hash-tables (lambda (body) + `(maphash (lambda (,var ,other) . ,body) + ,table))))) ((memq word '(symbol present-symbol external-symbol symbols present-symbols external-symbols)) (let ((ob (and (memq (car cl--loop-args) '(in of)) (cl--pop2 cl--loop-args)))) - (setq cl--loop-map-form - `(mapatoms (lambda (,var) . --cl-map) ,ob)))) + (cl--loop-set-iterator-function + 'symbols (lambda (body) + `(mapatoms (lambda (,var) . ,body) ,ob))))) ((memq word '(overlay overlays extent extents)) (let ((buf nil) (from nil) (to nil)) @@ -1214,11 +1267,12 @@ Valid clauses are: ((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)))) + (cl--loop-set-iterator-function + 'overlays (lambda (body) + `(cl--map-overlays + (lambda (,var ,(make-symbol "--cl-var--")) + (progn . ,body) nil) + ,buf ,from ,to))))) ((memq word '(interval intervals)) (let ((buf nil) (prop nil) (from nil) (to nil) @@ -1235,10 +1289,11 @@ Valid clauses are: (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) (setq var1 (car var) var2 (cdr var)) (push (list var `(cons ,var1 ,var2)) loop-for-sets)) - (setq cl--loop-map-form - `(cl--map-intervals - (lambda (,var1 ,var2) . --cl-map) - ,buf ,prop ,from ,to)))) + (cl--loop-set-iterator-function + 'intervals (lambda (body) + `(cl--map-intervals + (lambda (,var1 ,var2) . ,body) + ,buf ,prop ,from ,to))))) ((memq word key-types) (or (memq (car cl--loop-args) '(in of)) @@ -1254,10 +1309,11 @@ Valid clauses are: (make-symbol "--cl-var--")))) (if (memq word '(key-binding key-bindings)) (setq var (prog1 other (setq other var)))) - (setq cl--loop-map-form - `(,(if (memq word '(key-seq key-seqs)) - 'cl--map-keymap-recursively 'map-keymap) - (lambda (,var ,other) . --cl-map) ,cl-map)))) + (cl--loop-set-iterator-function + 'keys (lambda (body) + `(,(if (memq word '(key-seq key-seqs)) + 'cl--map-keymap-recursively 'map-keymap) + (lambda (,var ,other) . ,body) ,cl-map))))) ((memq word '(frame frames screen screens)) (let ((temp (make-symbol "--cl-var--"))) @@ -1428,12 +1484,9 @@ Valid clauses are: (if (eq word 'unless) (setq then (prog1 else (setq else then)))) (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) (if simple (nth 1 else) (list (nth 2 else)))))) - (if (cl--expr-contains form 'it) - (let ((temp (make-symbol "--cl-var--"))) - (push (list temp) cl--loop-bindings) - (setq form `(if (setq ,temp ,cond) - ,@(cl-subst temp 'it form)))) - (setq form `(if ,cond ,@form))) + (setq form (if (cl--expr-contains form 'it) + `(let ((it ,cond)) (if it ,@form)) + `(if ,cond ,@form))) (push (if simple `(progn ,form t) form) cl--loop-body)))) ((memq word '(do doing)) @@ -1458,36 +1511,50 @@ Valid clauses are: (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-* - (let ((p specs) (temps nil) (new nil)) - (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 (macroexp-const-p (cl-cadar p)) - (let ((temp (make-symbol "--cl-var--"))) - (push (list temp (cl-cadar p)) temps) - (setcar (cdar p) temp))) - (setq p (cdr p))))) +(defun cl--unused-var-p (sym) + (or (null sym) (eq ?_ (aref (symbol-name sym) 0)))) + +(defun cl--loop-let (specs body par) ; modifies cl--loop-bindings + "Build an expression equivalent to (let SPECS BODY). +SPECS can include bindings using `cl-loop's destructuring (not to be +confused with the patterns of `cl-destructuring-bind'). +If PAR is nil, do the bindings step by step, like `let*'. +If BODY is `setq', then use SPECS for assignments rather than for bindings." + (let ((temps nil) (new nil)) + (when par + (let ((p specs)) + (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p)))) + (setq p (cdr p))) + (when p + (setq par nil) + (dolist (spec specs) + (or (macroexp-const-p (cadr spec)) + (let ((temp (make-symbol "--cl-var--"))) + (push (list temp (cadr spec)) temps) + (setcar (cdr spec) temp))))))) (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 cl--loop-destr-temps) - (car (push (cons spec - (or (last spec 0) - (make-symbol "--cl-var--"))) - cl--loop-destr-temps)))))) - (push (list temp expr) new) - (while (consp spec) - (push (list (pop spec) - (and expr (list (if spec 'pop 'car) temp))) - nspecs)) - (setq specs (nconc (nreverse nspecs) specs))) - (push (pop specs) new))) + (let* ((binding (pop specs)) + (spec (car-safe binding))) + (if (and (consp binding) (or (consp spec) (cl--unused-var-p spec))) + (let* ((nspecs nil) + (expr (car (cdr-safe binding))) + (temp (last spec 0))) + (if (and (cl--unused-var-p temp) (null expr)) + nil ;; Don't bother declaring/setting `temp' since it won't + ;; be used when `expr' is nil, anyway. + (when (and (eq body 'setq) (cl--unused-var-p temp)) + ;; Prefer a fresh uninterned symbol over "_to", to avoid + ;; warnings that we set an unused variable. + (setq temp (make-symbol "--cl-var--")) + ;; Make sure this temp variable is locally declared. + (push (list (list temp)) cl--loop-bindings)) + (push (list temp expr) new)) + (while (consp spec) + (push (list (pop spec) + (and expr (list (if spec 'pop 'car) temp))) + nspecs)) + (setq specs (nconc (nreverse nspecs) specs))) + (push binding new)))) (if (eq body 'setq) (let ((set (cons (if par 'cl-psetq 'setq) (apply 'nconc (nreverse new))))) @@ -1925,11 +1992,18 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (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))) + (let ((expansion + ;; FIXME: For N bindings, this will traverse `body' N times! + (macroexpand-all (macroexp-progn body) + (cons (list (symbol-name (caar bindings)) + (cl-cadar bindings)) + macroexpand-all-environment)))) + (if (or (null (cdar bindings)) (cl-cddar bindings)) + (macroexp--warn-and-return + (format "Malformed `cl-symbol-macrolet' binding: %S" + (car bindings)) + expansion) + expansion))) (fset 'macroexpand previous-macroexpand)))))) ;;; Multiple values. @@ -1939,7 +2013,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). "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 `cl-multiple-value-bind' macro, using lists to +is analogous to the Common Lisp `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). @@ -1957,7 +2031,7 @@ a synonym for (list A B C). "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 -`cl-multiple-value-setq' macro, using lists to simulate true multiple return +`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)" @@ -1984,7 +2058,7 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (cons 'progn body)) ;;;###autoload (defmacro cl-the (_type form) - "At present this ignores _TYPE and is simply equivalent to FORM." + "At present this ignores TYPE and is simply equivalent to FORM." (declare (indent 1) (debug (cl-type-spec form))) form) @@ -2041,7 +2115,7 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). "Declare SPECS about the current function while compiling. For instance - \(cl-declare (warn 0)) + (cl-declare (warn 0)) will turn off byte-compile warnings in the function. See Info node `(cl)Declarations' for details." @@ -2258,10 +2332,11 @@ 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'. +Each SLOT may instead take the form (SNAME SDEFAULT SOPTIONS...), where +SDEFAULT is the default value of that slot and SOPTIONS 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...)" (declare (doc-string 2) (indent 1) @@ -2513,6 +2588,17 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (put ',name 'cl-deftype-handler (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body))))) +(defvar byte-compile-function-environment) +(defvar byte-compile-macro-environment) + +(defun cl--macroexp-fboundp (sym) + "Return non-nil if SYM will be bound when we run the code. +Of course, we really can't know that for sure, so it's just a heuristic." + (or (fboundp sym) + (and (cl--compiling-file) + (or (cdr (assq sym byte-compile-function-environment)) + (cdr (assq sym byte-compile-macro-environment)))))) + (defun cl--make-type-test (val type) (if (symbolp type) (cond ((get type 'cl-deftype-handler) @@ -2528,8 +2614,12 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (t (let* ((name (symbol-name type)) (namep (intern (concat name "p")))) - (if (fboundp namep) (list namep val) - (list (intern (concat name "-p")) val))))) + (cond + ((cl--macroexp-fboundp namep) (list namep val)) + ((cl--macroexp-fboundp + (setq namep (intern (concat name "-p")))) + (list namep val)) + (t (list type val)))))) (cond ((get (car type) 'cl-deftype-handler) (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler) (cdr type)))) @@ -2556,9 +2646,16 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (defun cl-typep (object type) ; See compiler macro below. "Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier." + (declare (compiler-macro cl--compiler-macro-typep)) (let ((cl--object object)) ;; Yuck!! (eval (cl--make-type-test 'cl--object type)))) +(defun cl--compiler-macro-typep (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)) + ;;;###autoload (defmacro cl-check-type (form type &optional string) "Verify that FORM is of type TYPE; signal an error if not. @@ -2613,23 +2710,17 @@ 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)) + (declare (debug cl-defmacro) (indent 2)) (let ((p args) (res nil)) (while (consp p) (push (pop p) res)) (setq args (nconc (nreverse res) (and p (list '&rest p))))) - `(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))))))) + (let ((fname (make-symbol (concat (symbol-name func) "--cmacro")))) + `(eval-and-compile + ;; Name the compiler-macro function, so that `symbol-file' can find it. + (cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args) + (cons '_cl-whole-arg args)) + ,@body) + (put ',func 'compiler-macro #',fname)))) ;;;###autoload (defun cl-compiler-macroexpand (form) @@ -2657,12 +2748,12 @@ macro that returns its `&whole' argument." (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)) + (macroexp-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)) + `(catch ,(nth 1 cl-form) ,@(macroexp-unprogn cl-body)) cl-body))) (cl-define-compiler-macro cl--block-throw (cl-tag cl-value) @@ -2673,15 +2764,18 @@ macro that returns its `&whole' argument." ;;;###autoload (defmacro cl-defsubst (name args &rest body) "Define NAME as a function. -Like `defun', except the function is automatically declared `inline', +Like `defun', except the function is automatically declared `inline' and +the arguments are immutable. ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (cl-block NAME ...). +The function's arguments should be treated as immutable. \(fn NAME ARGLIST [DOCSTRING] BODY...)" (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)))) + (let* ((argns (cl--arglist-args args)) + (p argns) + ;; (pbody (cons 'progn body)) + ) (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 @@ -2697,10 +2791,10 @@ surrounded by (cl-block NAME ...). ;; 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))) + ,(and (memq '&key args) 'cl-whole) nil ,@argns))) (cl-defun ,name ,args ,@body)))) -(defun cl--defsubst-expand (argns body simple whole unsafe &rest argvs) +(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 ()) @@ -2708,7 +2802,7 @@ surrounded by (cl-block NAME ...). (cl-mapcar (lambda (argn argv) (if (or simple (macroexp-const-p argv)) (progn (push (cons argn argv) substs) - (and unsafe (list argn argv))) + nil) (list argn argv))) argns argvs)))) ;; FIXME: `sublis/subst' will happily substitute the symbol @@ -2719,9 +2813,17 @@ surrounded by (cl-block NAME ...). (setq body (cond ((null substs) body) ((null (cdr substs)) (cl-subst (cdar substs) (caar substs) body)) - (t (cl-sublis substs body)))) + (t (cl--sublis substs body)))) (if lets `(let ,lets ,body) body)))) +(defun cl--sublis (alist tree) + "Perform substitutions indicated by ALIST in TREE (non-destructively)." + (let ((x (assq tree alist))) + (cond + (x (cdr x)) + ((consp tree) + (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) + (t tree)))) ;; Compile-time optimizations for some functions defined in this package. @@ -2745,22 +2847,16 @@ surrounded by (cl-block NAME ...). ;;;###autoload (defun cl--compiler-macro-adjoin (form a list &rest keys) - (if (and (cl--simple-expr-p a) (cl--simple-expr-p list) - (not (memq :key keys))) - `(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list)) - form)) + (if (memq :key keys) form + (macroexp-let2 macroexp-copyable-p va a + (macroexp-let2 macroexp-copyable-p vlist list + `(if (cl-member ,va ,vlist ,@keys) ,vlist (cons ,va ,vlist)))))) (defun cl--compiler-macro-get (_form sym prop &optional def) (if def `(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)) - (dolist (y '(cl-first cl-second cl-third cl-fourth cl-fifth cl-sixth cl-seventh cl-eighth cl-ninth cl-tenth diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index fbf68f62b4a..aa88264c4ab 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -1,9 +1,9 @@ ;;; cl-seq.el --- Common Lisp features, part 3 -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2014 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 +;; Old-Version: 2.02 ;; Keywords: extensions ;; Package: emacs diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index ea4d9511f9d..fc09ff004e1 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -1,6 +1,6 @@ ;;; cl.el --- Compatibility aliases for the old CL library. -*- lexical-binding: t -*- -;; Copyright (C) 2012-2013 Free Software Foundation, Inc. +;; Copyright (C) 2012-2014 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index b3fc6fb887a..1181e7a2ce0 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -1,6 +1,6 @@ ;;; copyright.el --- update the copyright notice in current buffer -;; Copyright (C) 1991-1995, 1998, 2001-2013 Free Software Foundation, +;; Copyright (C) 1991-1995, 1998, 2001-2014 Free Software Foundation, ;; Inc. ;; Author: Daniel Pfeiffer <occitan@esperanto.org> @@ -145,18 +145,17 @@ 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))) + ;; 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. + (with-demoted-errors "Can't update copyright: %s" + ;; (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))) (defun copyright-find-end () "Possibly adjust the search performed by `copyright-find-copyright'. diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index f88cb0ef9bb..c911d9d9293 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -1,6 +1,6 @@ ;;; crm.el --- read multiple strings with completion -;; Copyright (C) 1985-1986, 1993-2013 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1993-2014 Free Software Foundation, Inc. ;; Author: Sen Nagata <sen@eccosys.com> ;; Keywords: completion, minibuffer, multiple elements @@ -157,33 +157,32 @@ Functions'." predicate flag))) -(defun crm--select-current-element () +(defun crm--current-element () "Parse the minibuffer to find the current element. -Place an overlay on the element, with a `field' property, and return it." - (let* ((bob (minibuffer-prompt-end)) - (start (save-excursion +Return the element's boundaries as (START . END)." + (let ((bob (minibuffer-prompt-end))) + (cons (save-excursion (if (re-search-backward crm-separator bob t) (match-end 0) - bob))) - (end (save-excursion + bob)) + (save-excursion (if (re-search-forward crm-separator nil t) (match-beginning 0) - (point-max)))) - (ol (make-overlay start end nil nil t))) - (overlay-put ol 'field (make-symbol "crm")) - ol)) - -(defmacro crm--completion-command (command) - "Make COMMAND a completion command for `completing-read-multiple'." - `(let ((ol (crm--select-current-element))) - (unwind-protect - ,command - (delete-overlay ol)))) + (point-max)))))) + +(defmacro crm--completion-command (beg end &rest body) + "Run BODY with BEG and END bound to the current element's boundaries." + (declare (indent 2) (debug (sexp sexp &rest body))) + `(let* ((crm--boundaries (crm--current-element)) + (,beg (car crm--boundaries)) + (,end (cdr crm--boundaries))) + ,@body)) (defun crm-completion-help () "Display a list of possible completions of the current minibuffer element." (interactive) - (crm--completion-command (minibuffer-completion-help)) + (crm--completion-command beg end + (minibuffer-completion-help beg end)) nil) (defun crm-complete () @@ -192,13 +191,18 @@ If no characters can be completed, display a list of possible completions. Return t if the current element is now a valid match; otherwise return nil." (interactive) - (crm--completion-command (minibuffer-complete))) + (crm--completion-command beg end + (completion-in-region beg end + minibuffer-completion-table + minibuffer-completion-predicate))) (defun crm-complete-word () "Complete the current element at most a single word. Like `minibuffer-complete-word' but for `completing-read-multiple'." (interactive) - (crm--completion-command (minibuffer-complete-word))) + (crm--completion-command beg end + (completion-in-region--single-word + beg end minibuffer-completion-table minibuffer-completion-predicate))) (defun crm-complete-and-exit () "If all of the minibuffer elements are valid completions then exit. @@ -211,16 +215,14 @@ This function is modeled after `minibuffer-complete-and-exit'." (goto-char (minibuffer-prompt-end)) (while (and doexit - (let ((ol (crm--select-current-element))) - (goto-char (overlay-end ol)) - (unwind-protect - (catch 'exit - (minibuffer-complete-and-exit) - ;; This did not throw `exit', so there was a problem. - (setq doexit nil)) - (goto-char (overlay-end ol)) - (delete-overlay ol)) - (not (eobp))) + (crm--completion-command beg end + (let ((end (copy-marker end t))) + (goto-char end) + (setq doexit nil) + (completion-complete-and-exit beg end + (lambda () (setq doexit t))) + (goto-char end) + (not (eobp)))) (looking-at crm-separator)) ;; Skip to the next element. (goto-char (match-end 0))) @@ -263,7 +265,8 @@ Completion is available on a per-element basis. For example, if the contents of the minibuffer are 'alice,bob,eve' and point is between 'l' and 'i', pressing TAB operates on the element 'alice'. -The return value of this function is a list of the read strings. +The return value of this function is a list of the read strings +with empty strings removed. See the documentation for `completing-read' for details on the arguments: PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-INPUT, HIST, DEF, and @@ -287,7 +290,8 @@ INHERIT-INPUT-METHOD." prompt initial-input map nil hist def inherit-input-method))) (and def (string-equal input "") (setq input def)) - (split-string input crm-separator))) + ;; Remove empty strings in the list of read strings. + (split-string input crm-separator t))) (remove-hook 'choose-completion-string-functions 'crm--choose-completion-string))) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 0728e86d072..ab6368beeab 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -1,9 +1,9 @@ ;;; debug.el --- debuggers and related commands for Emacs -*- lexical-binding: t -*- -;; Copyright (C) 1985-1986, 1994, 2001-2013 Free Software Foundation, +;; Copyright (C) 1985-1986, 1994, 2001-2014 Free Software Foundation, ;; Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, tools, maint ;; This file is part of GNU Emacs. @@ -102,22 +102,6 @@ The value used here is passed to `quit-restore-window'." This is to optimize `debugger-make-xrefs'.") (defvar debugger-outer-match-data) -(defvar debugger-outer-load-read-function) -(defvar debugger-outer-overriding-local-map) -(defvar debugger-outer-overriding-terminal-local-map) -(defvar debugger-outer-track-mouse) -(defvar debugger-outer-last-command) -(defvar debugger-outer-this-command) -(defvar debugger-outer-unread-command-events) -(defvar debugger-outer-unread-post-input-method-events) -(defvar debugger-outer-last-input-event) -(defvar debugger-outer-last-command-event) -(defvar debugger-outer-last-nonmenu-event) -(defvar debugger-outer-last-event-frame) -(defvar debugger-outer-standard-input) -(defvar debugger-outer-standard-output) -(defvar debugger-outer-inhibit-redisplay) -(defvar debugger-outer-cursor-in-echo-area) (defvar debugger-will-be-back nil "Non-nil if we expect to get back in the debugger soon.") @@ -174,24 +158,6 @@ first will be printed into the backtrace buffer." ;; Save the outer values of these vars for the `e' command ;; before we replace the values. (debugger-outer-match-data (match-data)) - (debugger-outer-load-read-function load-read-function) - (debugger-outer-overriding-local-map overriding-local-map) - (debugger-outer-overriding-terminal-local-map - overriding-terminal-local-map) - (debugger-outer-track-mouse track-mouse) - (debugger-outer-last-command last-command) - (debugger-outer-this-command this-command) - (debugger-outer-unread-command-events unread-command-events) - (debugger-outer-unread-post-input-method-events - unread-post-input-method-events) - (debugger-outer-last-input-event last-input-event) - (debugger-outer-last-command-event last-command-event) - (debugger-outer-last-nonmenu-event last-nonmenu-event) - (debugger-outer-last-event-frame last-event-frame) - (debugger-outer-standard-input standard-input) - (debugger-outer-standard-output standard-output) - (debugger-outer-inhibit-redisplay inhibit-redisplay) - (debugger-outer-cursor-in-echo-area cursor-in-echo-area) (debugger-with-timeout-suspend (with-timeout-suspend))) ;; Set this instead of binding it, so that `q' ;; will not restore it. @@ -238,7 +204,7 @@ first will be printed into the backtrace buffer." (window-resize debugger-window (- debugger-previous-window-height - (window-total-size debugger-window))) + (window-total-height debugger-window))) (error nil))) (setq debugger-previous-window debugger-window)) (debugger-mode) @@ -270,7 +236,7 @@ first will be printed into the backtrace buffer." (eq (window-buffer debugger-window) debugger-buffer)) ;; Record height of debugger window. (setq debugger-previous-window-height - (window-total-size debugger-window))) + (window-total-height debugger-window))) (if debugger-will-be-back ;; Restore previous window configuration (Bug#12623). (set-window-configuration window-configuration) @@ -294,26 +260,6 @@ first will be printed into the backtrace buffer." (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 - ;; in case the user set them with the `e' command. - (setq load-read-function debugger-outer-load-read-function) - (setq overriding-local-map debugger-outer-overriding-local-map) - (setq overriding-terminal-local-map - debugger-outer-overriding-terminal-local-map) - (setq track-mouse debugger-outer-track-mouse) - (setq last-command debugger-outer-last-command) - (setq this-command debugger-outer-this-command) - (setq unread-command-events debugger-outer-unread-command-events) - (setq unread-post-input-method-events - debugger-outer-unread-post-input-method-events) - (setq last-input-event debugger-outer-last-input-event) - (setq last-command-event debugger-outer-last-command-event) - (setq last-nonmenu-event debugger-outer-last-nonmenu-event) - (setq last-event-frame debugger-outer-last-event-frame) - (setq standard-input debugger-outer-standard-input) - (setq standard-output debugger-outer-standard-output) - (setq inhibit-redisplay debugger-outer-inhibit-redisplay) - (setq cursor-in-echo-area debugger-outer-cursor-in-echo-area) (setq debug-on-next-call debugger-step-after-exit) debugger-value))) @@ -342,33 +288,41 @@ 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. - (pcase (car args) - ((or `lambda `debug) - (insert "--entering a function:\n")) - ;; Exiting a function. - (`exit - (insert "--returning value: ") - (setq debugger-value (nth 1 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 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 args) 'nil) - (cdr args) args) - (current-buffer)) - (insert ?\n))) + (let ((pos (point))) + (pcase (car args) + ((or `lambda `debug) + (insert "--entering a function:\n") + (setq pos (1- (point)))) + ;; Exiting a function. + (`exit + (insert "--returning value: ") + (setq pos (point)) + (setq debugger-value (nth 1 args)) + (prin1 debugger-value (current-buffer)) + (insert ?\n) + (delete-char 1) + (insert ? ) + (beginning-of-line)) + ;; Debugger entered for an error. + (`error + (insert "--Lisp error: ") + (setq pos (point)) + (prin1 (nth 1 args) (current-buffer)) + (insert ?\n)) + ;; debug-on-call, when the next thing is an eval. + (`t + (insert "--beginning evaluation of function call form:\n") + (setq pos (1- (point)))) + ;; User calls debug directly. + (_ + (insert ": ") + (setq pos (point)) + (prin1 (if (eq (car args) 'nil) + (cdr args) args) + (current-buffer)) + (insert ?\n))) + ;; Place point on "stack frame 0" (bug#15101). + (goto-char pos)) ;; After any frame that uses eval-buffer, ;; insert a line that states the buffer position it's reading at. (save-excursion @@ -518,18 +472,21 @@ removes itself from that hook." (setq debugger-jumping-flag nil) (remove-hook 'post-command-hook 'debugger-reenable)) -(defun debugger-frame-number () +(defun debugger-frame-number (&optional skip-base) "Return number of frames in backtrace before the one point points at." (save-excursion (beginning-of-line) + (if (looking-at " *;;;\\|[a-z]") + (error "This line is not a function call")) (let ((opoint (point)) (count 0)) - (while (not (eq (cadr (backtrace-frame count)) 'debug)) - (setq count (1+ count))) - ;; Skip debug--implement-debug-on-entry frame. - (when (eq 'debug--implement-debug-on-entry - (cadr (backtrace-frame (1+ count)))) - (setq count (+ 2 count))) + (unless skip-base + (while (not (eq (cadr (backtrace-frame count)) 'debug)) + (setq count (1+ count))) + ;; Skip debug--implement-debug-on-entry frame. + (when (eq 'debug--implement-debug-on-entry + (cadr (backtrace-frame (1+ count)))) + (setq count (+ 2 count)))) (goto-char (point-min)) (when (looking-at "Debugger entered--\\(Lisp error\\|returning value\\):") (goto-char (match-end 0)) @@ -537,9 +494,13 @@ removes itself from that hook." (forward-line 1) (while (progn (forward-char 2) - (if (= (following-char) ?\() - (forward-sexp 1) - (forward-sexp 2)) + (cond ((debugger--locals-visible-p) + (goto-char (next-single-char-property-change + (point) 'locals-visible))) + ((= (following-char) ?\() + (forward-sexp 1)) + (t + (forward-sexp 2))) (forward-line 1) (<= (point) opoint)) (if (looking-at " *;;;") @@ -551,12 +512,8 @@ removes itself from that hook." "Request entry to debugger when this frame exits. Applies to the frame whose line point is on in the backtrace." (interactive) - (save-excursion - (beginning-of-line) - (if (looking-at " *;;;\\|[a-z]") - (error "This line is not a function call"))) - (beginning-of-line) (backtrace-debug (debugger-frame-number) t) + (beginning-of-line) (if (= (following-char) ? ) (let ((inhibit-read-only t)) (delete-char 1) @@ -567,12 +524,8 @@ Applies to the frame whose line point is on in the backtrace." "Do not enter debugger when this frame exits. Applies to the frame whose line point is on in the backtrace." (interactive) - (save-excursion - (beginning-of-line) - (if (looking-at " *;;;\\|[a-z]") - (error "This line is not a function call"))) - (beginning-of-line) (backtrace-debug (debugger-frame-number) nil) + (beginning-of-line) (if (= (following-char) ?*) (let ((inhibit-read-only t)) (delete-char 1) @@ -583,59 +536,95 @@ Applies to the frame whose line point is on in the backtrace." "Run BODY in original environment." (declare (indent 0)) `(save-excursion - (if (null (buffer-name debugger-old-buffer)) + (if (null (buffer-live-p debugger-old-buffer)) ;; old buffer deleted (setq debugger-old-buffer (current-buffer))) (set-buffer debugger-old-buffer) - (let ((load-read-function debugger-outer-load-read-function) - (overriding-terminal-local-map - debugger-outer-overriding-terminal-local-map) - (overriding-local-map debugger-outer-overriding-local-map) - (track-mouse debugger-outer-track-mouse) - (last-command debugger-outer-last-command) - (this-command debugger-outer-this-command) - (unread-command-events debugger-outer-unread-command-events) - (unread-post-input-method-events - debugger-outer-unread-post-input-method-events) - (last-input-event debugger-outer-last-input-event) - (last-command-event debugger-outer-last-command-event) - (last-nonmenu-event debugger-outer-last-nonmenu-event) - (last-event-frame debugger-outer-last-event-frame) - (standard-input debugger-outer-standard-input) - (standard-output debugger-outer-standard-output) - (inhibit-redisplay debugger-outer-inhibit-redisplay) - (cursor-in-echo-area debugger-outer-cursor-in-echo-area)) - (set-match-data debugger-outer-match-data) - (prog1 - (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 - overriding-terminal-local-map) - (setq debugger-outer-overriding-local-map overriding-local-map) - (setq debugger-outer-track-mouse track-mouse) - (setq debugger-outer-last-command last-command) - (setq debugger-outer-this-command this-command) - (setq debugger-outer-unread-command-events unread-command-events) - (setq debugger-outer-unread-post-input-method-events - unread-post-input-method-events) - (setq debugger-outer-last-input-event last-input-event) - (setq debugger-outer-last-command-event last-command-event) - (setq debugger-outer-last-nonmenu-event last-nonmenu-event) - (setq debugger-outer-last-event-frame last-event-frame) - (setq debugger-outer-standard-input standard-input) - (setq debugger-outer-standard-output standard-output) - (setq debugger-outer-inhibit-redisplay inhibit-redisplay) - (setq debugger-outer-cursor-in-echo-area cursor-in-echo-area) - )))) - -(defun debugger-eval-expression (exp) - "Eval an expression, in an environment like that outside the debugger." + (set-match-data debugger-outer-match-data) + (prog1 + (progn ,@body) + (setq debugger-outer-match-data (match-data))))) + +(defun debugger--backtrace-base () + "Return the function name that marks the top of the backtrace. +See `backtrace-frame'." + (cond ((eq 'debug--implement-debug-on-entry + (cadr (backtrace-frame 1 'debug))) + 'debug--implement-debug-on-entry) + (t 'debug))) + +(defun debugger-eval-expression (exp &optional nframe) + "Eval an expression, in an environment like that outside the debugger. +The environment used is the one when entering the activation frame at point." (interactive - (list (read-from-minibuffer "Eval: " - nil read-expression-map t - 'read-expression-history))) - (debugger-env-macro (eval-expression exp))) + (list (read--expression "Eval in stack frame: "))) + (let ((nframe (or nframe + (condition-case nil (1+ (debugger-frame-number 'skip-base)) + (error 0)))) ;; If on first line. + (base (debugger--backtrace-base))) + (debugger-env-macro + (let ((val (backtrace-eval exp nframe base))) + (prog1 + (prin1 val t) + (let ((str (eval-expression-print-format val))) + (if str (princ str t)))))))) + +(defun debugger--locals-visible-p () + "Are the local variables of the current stack frame visible?" + (save-excursion + (move-to-column 2) + (get-text-property (point) 'locals-visible))) + +(defun debugger--insert-locals (locals) + "Insert the local variables LOCALS at point." + (cond ((null locals) + (insert "\n [no locals]")) + (t + (let ((print-escape-newlines t)) + (dolist (s+v locals) + (let ((symbol (car s+v)) + (value (cdr s+v))) + (insert "\n ") + (prin1 symbol (current-buffer)) + (insert " = ") + (prin1 value (current-buffer)))))))) + +(defun debugger--show-locals () + "For the frame at point, insert locals and add text properties." + (let* ((nframe (1+ (debugger-frame-number 'skip-base))) + (base (debugger--backtrace-base)) + (locals (backtrace--locals nframe base)) + (inhibit-read-only t)) + (save-excursion + (let ((start (progn + (move-to-column 2) + (point)))) + (end-of-line) + (debugger--insert-locals locals) + (add-text-properties start (point) '(locals-visible t)))))) + +(defun debugger--hide-locals () + "Delete local variables and remove the text property." + (let* ((col (current-column)) + (end (progn + (move-to-column 2) + (next-single-char-property-change (point) 'locals-visible))) + (start (previous-single-char-property-change end 'locals-visible)) + (inhibit-read-only t)) + (remove-text-properties start end '(locals-visible)) + (goto-char start) + (end-of-line) + (delete-region (point) end) + (move-to-column col))) + +(defun debugger-toggle-locals () + "Show or hide local variables of the current stack frame." + (interactive) + (cond ((debugger--locals-visible-p) + (debugger--hide-locals)) + (t + (debugger--show-locals)))) + (defvar debugger-mode-map (let ((map (make-keymap)) @@ -653,6 +642,7 @@ Applies to the frame whose line point is on in the backtrace." (define-key map "h" 'describe-mode) (define-key map "q" 'top-level) (define-key map "e" 'debugger-eval-expression) + (define-key map "v" 'debugger-toggle-locals) ; "v" is for "variables". (define-key map " " 'next-line) (define-key map "R" 'debugger-record-expression) (define-key map "\C-m" 'debug-help-follow) @@ -704,7 +694,7 @@ Applies to the frame whose line point is on in the backtrace." (put 'debugger-mode 'mode-class 'special) -(defun debugger-mode () +(define-derived-mode debugger-mode fundamental-mode "Debugger" "Mode for backtrace buffers, selected in debugger. \\<debugger-mode-map> A line starts with `*' if exiting that frame will call the debugger. @@ -719,13 +709,9 @@ which functions will enter the debugger when called. Complete list of commands: \\{debugger-mode-map}" - (kill-all-local-variables) - (setq major-mode 'debugger-mode) - (setq mode-name "Debugger") (setq truncate-lines t) (set-syntax-table emacs-lisp-mode-syntax-table) - (use-local-map debugger-mode-map) - (run-mode-hooks 'debugger-mode-hook)) + (use-local-map debugger-mode-map)) (defcustom debugger-record-buffer "*Debugger-record*" "Buffer name for expression values, for \\[debugger-record-expression]." @@ -736,11 +722,7 @@ Complete list of commands: (defun debugger-record-expression (exp) "Display a variable's value and record it in `*Backtrace-record*' buffer." (interactive - (list (read-from-minibuffer - "Record Eval: " - nil - read-expression-map t - 'read-expression-history))) + (list (read--expression "Record Eval: "))) (let* ((buffer (get-buffer-create debugger-record-buffer)) (standard-output buffer)) (princ (format "Debugger Eval (%s): " exp)) @@ -816,7 +798,8 @@ Redefining FUNCTION also cancels it." (not (special-form-p symbol)))) t nil nil (symbol-name fn))) (list (if (equal val "") fn (intern val))))) - (advice-add function :before #'debug--implement-debug-on-entry) + (advice-add function :before #'debug--implement-debug-on-entry + '((depth . -100))) function) (defun debug--function-list () @@ -846,7 +829,7 @@ To specify a nil argument interactively, exit with an empty minibuffer." (progn (advice-remove function #'debug--implement-debug-on-entry) function) - (message "Cancelling debug-on-entry for all functions") + (message "Canceling debug-on-entry for all functions") (mapcar #'cancel-debug-on-entry (debug--function-list)))) (defun debugger-list-functions () diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 684f9d90878..a6ccedc0310 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -1,11 +1,11 @@ ;;; derived.el --- allow inheritance of major modes ;; (formerly mode-clone.el) -;; Copyright (C) 1993-1994, 1999, 2001-2013 Free Software Foundation, +;; Copyright (C) 1993-1994, 1999, 2001-2014 Free Software Foundation, ;; Inc. ;; Author: David Megginson (dmeggins@aix1.uottawa.ca) -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: extensions ;; Package: emacs @@ -192,12 +192,11 @@ See Info node `(elisp)Derived Modes' for more details." parent child docstring syntax abbrev)) `(progn - (unless (get ',hook 'variable-documentation) - (put ',hook 'variable-documentation - (purecopy ,(format "Hook run when entering %s mode. + (defvar ,hook nil + ,(format "Hook run after entering %s mode. No problems result if this variable is not bound. `add-hook' automatically binds it. (This is true for all hook variables.)" - name)))) + name)) (unless (boundp ',map) (put ',map 'definition-name ',child)) (with-no-warnings (defvar ,map (make-sparse-keymap))) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index dc0e55df500..bf013ea84e1 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -1,10 +1,10 @@ ;;; disass.el --- disassembler for compiled Emacs Lisp code -;; Copyright (C) 1986, 1991, 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 1986, 1991, 2002-2014 Free Software Foundation, Inc. ;; Author: Doug Cutting <doug@csli.stanford.edu> ;; Jamie Zawinski <jwz@lucid.com> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index abe7b1ea741..2db629ea86c 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -1,6 +1,6 @@ ;;; easy-mmode.el --- easy definition for major and minor modes -;; Copyright (C) 1997, 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 1997, 2000-2014 Free Software Foundation, Inc. ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr> ;; Maintainer: Stefan Monnier <monnier@gnu.org> @@ -296,6 +296,12 @@ the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. ;; up-to-here. :autoload-end + (defvar ,hook nil + ,(format "Hook run after entering or leaving `%s'. +No problems result if this variable is not bound. +`add-hook' automatically binds it. (This is true for all hook variables.)" + mode)) + ;; Define the minor-mode keymap. ,(unless (symbolp keymap) ;nil is also a symbol. `(defvar ,keymap-sym @@ -413,12 +419,19 @@ See `%s' for more information on %s." ;; Go through existing buffers. (dolist (buf (buffer-list)) (with-current-buffer buf - (if ,global-mode (,turn-on) (when ,mode (,mode -1)))))) + (if ,global-mode (funcall #',turn-on) (when ,mode (,mode -1)))))) ;; Autoloading define-globalized-minor-mode autoloads everything ;; up-to-here. :autoload-end + ;; MODE-set-explicitly is set in MODE-set-explicitly and cleared by + ;; kill-all-local-variables. + (defvar-local ,MODE-set-explicitly nil) + (defun ,MODE-set-explicitly () + (setq ,MODE-set-explicitly t)) + (put ',MODE-set-explicitly 'definition-name ',global-mode) + ;; A function which checks whether MODE has been disabled in the major ;; mode hook which has just been run. (add-hook ',minor-MODE-hook ',MODE-set-explicitly) @@ -436,8 +449,8 @@ See `%s' for more information on %s." (if ,mode (progn (,mode -1) - (,turn-on)) - (,turn-on)))) + (funcall #',turn-on)) + (funcall #',turn-on)))) (setq ,MODE-major-mode major-mode))))) (put ',MODE-enable-in-buffers 'definition-name ',global-mode) @@ -451,13 +464,7 @@ See `%s' for more information on %s." (defun ,MODE-cmhh () (add-to-list ',MODE-buffers (current-buffer)) (add-hook 'post-command-hook ',MODE-check-buffers)) - (put ',MODE-cmhh 'definition-name ',global-mode) - ;; MODE-set-explicitly is set in MODE-set-explicitly and cleared by - ;; kill-all-local-variables. - (defvar-local ,MODE-set-explicitly nil) - (defun ,MODE-set-explicitly () - (setq ,MODE-set-explicitly t)) - (put ',MODE-set-explicitly 'definition-name ',global-mode)))) + (put ',MODE-cmhh 'definition-name ',global-mode)))) ;;; ;;; easy-mmode-defmap @@ -582,7 +589,7 @@ BODY is executed after moving to the destination location." (prog1 (or (< (- (point-max) (point-min)) (buffer-size))) (widen)))) ,body - (when was-narrowed (,narrowfun))))))) + (when was-narrowed (funcall #',narrowfun))))))) (unless name (setq name base-name)) `(progn (defun ,next-sym (&optional count) @@ -594,13 +601,13 @@ BODY is executed after moving to the destination location." ,(funcall when-narrowed `(if (not (re-search-forward ,re nil t count)) (if (looking-at ,re) - (goto-char (or ,(if endfun `(,endfun)) (point-max))) + (goto-char (or ,(if endfun `(funcall #',endfun)) (point-max))) (user-error "No next %s" ,name)) (goto-char (match-beginning 0)) - (when (and (eq (current-buffer) (window-buffer (selected-window))) + (when (and (eq (current-buffer) (window-buffer)) (called-interactively-p 'interactive)) (let ((endpt (or (save-excursion - ,(if endfun `(,endfun) + ,(if endfun `(funcall #',endfun) `(re-search-forward ,re nil t 2))) (point-max)))) (unless (pos-visible-in-window-p endpt nil t) diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index f33ae54bf25..8a30266c2a9 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -1,6 +1,6 @@ -;;; easymenu.el --- support the easymenu interface for defining a menu +;;; easymenu.el --- support the easymenu interface for defining a menu -*- lexical-binding:t -*- -;; Copyright (C) 1994, 1996, 1998-2013 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1996, 1998-2014 Free Software Foundation, Inc. ;; Keywords: emulations ;; Author: Richard Stallman <rms@gnu.org> @@ -218,21 +218,22 @@ MENU-NAME is a string, the name of the menu. MENU-ITEMS is a list of items possibly preceded by keyword pairs as described in `easy-menu-define'." (let ((menu (make-sparse-keymap menu-name)) (easy-menu-avoid-duplicate-keys nil) - prop keyword arg label enable filter visible help) + prop keyword label enable filter visible help) ;; Look for keywords. (while (and menu-items (cdr menu-items) (keywordp (setq keyword (car menu-items)))) - (setq arg (cadr menu-items)) - (setq menu-items (cddr menu-items)) - (pcase keyword - (`:filter - (setq filter `(lambda (menu) - (easy-menu-filter-return (,arg menu) ,menu-name)))) - ((or `:enable `:active) (setq enable (or arg ''nil))) - (`:label (setq label arg)) - (`:help (setq help arg)) - ((or `:included `:visible) (setq visible (or arg ''nil))))) + (let ((arg (cadr menu-items))) + (setq menu-items (cddr menu-items)) + (pcase keyword + (`:filter + (setq filter (lambda (menu) + (easy-menu-filter-return (funcall arg menu) + menu-name)))) + ((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))) @@ -496,7 +497,7 @@ Contrary to XEmacs, this is a nop on Emacs since menus are automatically \(fn MENU)") -(defun easy-menu-add (menu &optional map) +(defun easy-menu-add (_menu &optional _map) "Add the menu to the menubar. On Emacs, menus are already automatically activated when the corresponding keymap is activated. On XEmacs this is needed to diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 52e12013fd3..e4bcb4bf294 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1,10 +1,10 @@ ;;; edebug.el --- a source-level debugger for Emacs Lisp -*- lexical-binding: t -*- -;; Copyright (C) 1988-1995, 1997, 1999-2013 Free Software Foundation, +;; Copyright (C) 1988-1995, 1997, 1999-2014 Free Software Foundation, ;; Inc. ;; Author: Daniel LaLiberte <liberte@holonexus.org> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, tools, maint ;; This file is part of GNU Emacs. @@ -53,7 +53,8 @@ ;;; Code: (require 'macroexp) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) +(eval-when-compile (require 'pcase)) ;;; Options @@ -262,26 +263,6 @@ An extant spec symbol is a symbol that is not a function and has a ;;; Utilities -;; Define edebug-gensym - from old cl.el -(defvar edebug-gensym-index 0 - "Integer used by `edebug-gensym' to produce new names.") - -(defun edebug-gensym (&optional prefix) - "Generate a fresh uninterned symbol. -There is an optional argument, PREFIX. PREFIX is the string -that begins the new name. Most people take just the default, -except when debugging needs suggest otherwise." - (if (null prefix) - (setq prefix "G")) - (let ((newsymbol nil) - (newname "")) - (while (not newsymbol) - (setq newname (concat prefix (int-to-string edebug-gensym-index))) - (setq edebug-gensym-index (+ edebug-gensym-index 1)) - (if (not (intern-soft newname)) - (setq newsymbol (make-symbol newname)))) - newsymbol)) - (defun edebug-lambda-list-keywordp (object) "Return t if OBJECT is a lambda list keyword. A lambda list keyword is a symbol that starts with `&'." @@ -312,20 +293,7 @@ A lambda list keyword is a symbol that starts with `&'." "Return t if there are two windows." (and (not (one-window-p)) (eq (selected-window) - (next-window (next-window (selected-window)))))) - -(defsubst edebug-lookup-function (object) - (while (and (symbolp object) (fboundp object)) - (setq object (symbol-function object))) - object) - -(defun edebug-macrop (object) - "Return the macro named by OBJECT, or nil if it is not a macro." - (setq object (edebug-lookup-function object)) - (if (and (listp object) - (eq 'macro (car object)) - (functionp (cdr object))) - object)) + (next-window (next-window))))) (defun edebug-sort-alist (alist function) ;; Return the ALIST sorted with comparison function FUNCTION. @@ -366,7 +334,7 @@ Return the result of the last expression in BODY." ((and (edebug-window-live-p window) (eq (window-buffer window) buffer)) window) - ((eq (window-buffer (selected-window)) buffer) + ((eq (window-buffer) buffer) ;; Selected window already displays BUFFER. (selected-window)) ((get-buffer-window buffer 0)) @@ -471,6 +439,8 @@ the option `edebug-all-forms'." (or (fboundp 'edebug-original-eval-defun) (defalias 'edebug-original-eval-defun (symbol-function 'eval-defun))) +(defvar edebug-result) ; The result of the function call returned by body. + ;; We should somehow arrange to be able to do this ;; without actually replacing the eval-defun command. (defun edebug-eval-defun (edebug-it) @@ -486,7 +456,7 @@ With a prefix argument, instrument the code for Edebug. Setting option `edebug-all-defs' to a non-nil value reverses the meaning of the prefix argument. Code is then instrumented when this function is -invoked without a prefix argument +invoked without a prefix argument. If acting on a `defun' for FUNCTION, and the function was instrumented, `Edebug: FUNCTION' is printed in the minibuffer. If not instrumented, @@ -527,7 +497,10 @@ the minibuffer." (put (nth 1 form) 'saved-face nil))))) (setq edebug-result (eval (eval-sexp-add-defvars form) lexical-binding)) (if (not edebugging) - (princ edebug-result) + (prog1 + (princ edebug-result) + (let ((str (eval-expression-print-format edebug-result))) + (if str (princ str)))) edebug-result))) @@ -1183,7 +1156,7 @@ Maybe clear the markers and delete the symbol's edebug property?" ;; Uses the dynamically bound vars edebug-def-name and edebug-def-args. ;; Do this after parsing since that may find a name. (setq edebug-def-name - (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon"))) + (or edebug-def-name edebug-old-def-name (cl-gensym "edebug-anon"))) `(edebug-enter (quote ,edebug-def-name) ,(if edebug-inside-func @@ -1296,7 +1269,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Set the name here if it was not set by edebug-make-enter-wrapper. (setq edebug-def-name - (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon"))) + (or edebug-def-name edebug-old-def-name (cl-gensym "edebug-anon"))) ;; Add this def as a dependent of containing def. Buggy. '(if (and edebug-containing-def-name @@ -1433,7 +1406,7 @@ expressions; a `progn' form will be returned enclosing these forms." ; but leave it in for compatibility. )) ;; No edebug-form-spec provided. - ((edebug-macrop head) + ((macrop head) (if edebug-eval-macro-args (edebug-forms cursor) (edebug-sexps cursor))) @@ -2072,11 +2045,6 @@ expressions; a `progn' form will be returned enclosing these forms." (defvar edebug-active nil) ;; Non-nil when edebug is active -;;; add minor-mode-alist entry -(or (assq 'edebug-active minor-mode-alist) - (setq minor-mode-alist (cons (list 'edebug-active " *Debugging*") - minor-mode-alist))) - (defvar edebug-stack nil) ;; Stack of active functions evaluated via edebug. ;; Should be nil at the top level. @@ -2110,9 +2078,6 @@ expressions; a `progn' form will be returned enclosing these forms." (defvar edebug-coverage) ; the coverage results of each expression of function. (defvar edebug-buffer) ; which buffer the function is in. -(defvar edebug-result) ; the result of the function call returned by body -(defvar edebug-outside-executing-macro) -(defvar edebug-outside-defining-kbd-macro) (defvar edebug-execution-mode 'step) ; Current edebug mode set by user. (defvar edebug-next-execution-mode nil) ; Use once instead of initial mode. @@ -2120,12 +2085,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-pre-command-hook) -(defvar edebug-outside-post-command-hook) - -(defvar cl-lexical-debug) ;; Defined in cl.el - ;;; Handling signals (defun edebug-signal (signal-name signal-data) @@ -2177,10 +2136,7 @@ error is signaled again." ;; 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)) + (debug-on-quit edebug-on-quit)) (unwind-protect (let ((signal-hook-function 'edebug-signal)) (setq edebug-execution-mode (or edebug-next-execution-mode @@ -2361,8 +2317,7 @@ MSG is printed after `::::} '." (if edebug-global-break-condition (condition-case nil (setq edebug-global-break-result - ;; FIXME: lexbind. - (eval edebug-global-break-condition)) + (edebug-eval edebug-global-break-condition)) (error nil)))) (edebug-break)) @@ -2373,8 +2328,7 @@ MSG is printed after `::::} '." (and edebug-break-data (or (not edebug-break-condition) (setq edebug-break-result - ;; FIXME: lexbind. - (eval edebug-break-condition)))))) + (edebug-eval edebug-break-condition)))))) (if (and edebug-break (nth 2 edebug-break-data)) ; is it temporary? ;; Delete the breakpoint. @@ -2409,9 +2363,6 @@ MSG is printed after `::::} '." (defvar edebug-window-data) ; window and window-start for current function (defvar edebug-outside-windows) ; outside window configuration (defvar edebug-eval-buffer) ; for the evaluation list. -(defvar edebug-outside-o-a-p) ; outside overlay-arrow-position -(defvar edebug-outside-o-a-s) ; outside overlay-arrow-string -(defvar edebug-outside-c-i-e-a) ; outside cursor-in-echo-area (defvar edebug-outside-d-c-i-n-s-w) ; outside default-cursor-in-non-selected-windows (defvar edebug-eval-list nil) ;; List of expressions to evaluate. @@ -2421,8 +2372,6 @@ 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 (value offset-index arg-mode) (unless (marker-position edebug-def-mark) ;; The buffer holding the source has been killed. @@ -2444,7 +2393,6 @@ MSG is printed after `::::} '." (edebug-outside-buffer (current-buffer)) (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-buffer-points @@ -2454,22 +2402,16 @@ MSG is printed after `::::} '." edebug-trace-window edebug-trace-window-start - (edebug-outside-o-a-p overlay-arrow-position) - (edebug-outside-o-a-s overlay-arrow-string) - (edebug-outside-c-i-e-a cursor-in-echo-area) (edebug-outside-d-c-i-n-s-w (default-value 'cursor-in-non-selected-windows))) (unwind-protect - (let ((overlay-arrow-position overlay-arrow-position) - (overlay-arrow-string overlay-arrow-string) - (cursor-in-echo-area nil) + (let ((cursor-in-echo-area nil) (unread-command-events nil) ;; any others?? ) (setq-default cursor-in-non-selected-windows t) (if (not (buffer-name edebug-buffer)) - (let ((debug-on-error nil)) - (error "Buffer defining %s not found" edebug-function))) + (user-error "Buffer defining %s not found" edebug-function)) (if (eq 'after arg-mode) ;; Compute result string now before windows are modified. @@ -2509,10 +2451,9 @@ MSG is printed after `::::} '." ;; Check whether positions are up-to-date. ;; This assumes point is never before symbol. (if (not (memq (following-char) '(?\( ?\# ?\` ))) - (let ((debug-on-error nil)) - (error "Source has changed - reevaluate definition of %s" - edebug-function) - ))) + (user-error "Source has changed - reevaluate definition of %s" + edebug-function) + )) (setcdr edebug-window-data (edebug-adjust-window (cdr edebug-window-data))) @@ -2525,136 +2466,141 @@ MSG is printed after `::::} '." (edebug-stop) ;; (discard-input) ; is this unfriendly?? )) - ;; Now display arrow based on mode. - (edebug-overlay-arrow) - (cond - ((eq 'error arg-mode) - ;; Display error message - (setq edebug-execution-mode 'step) - (edebug-overlay-arrow) - (beep) - (if (eq 'quit (car value)) - (message "Quit") - (edebug-report-error value))) - (edebug-break - (cond - (edebug-global-break - (message "Global Break: %s => %s" - edebug-global-break-condition - edebug-global-break-result)) - (edebug-break-condition - (message "Break: %s => %s" - edebug-break-condition - edebug-break-result)) - ((not (eq edebug-execution-mode 'Continue-fast)) - (message "Break")) - (t))) - - (t (message ""))) - - (if (eq 'after arg-mode) - (progn - ;; Display result of previous evaluation. - (if (and edebug-break - (not (eq edebug-execution-mode 'Continue-fast))) - (sit-for edebug-sit-for-seconds)) ; Show message. - (edebug-previous-result))) - - (cond - (edebug-break - (cond - ((eq edebug-execution-mode 'continue) - (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) - (sit-for edebug-sit-for-seconds)) ; Force update and pause. - ((eq edebug-execution-mode 'Trace-fast) - (sit-for 0))) ; Force update and continue. + ;; Make sure we bind those in the right buffer (bug#16410). + (let ((overlay-arrow-position overlay-arrow-position) + (overlay-arrow-string overlay-arrow-string)) + ;; Now display arrow based on mode. + (edebug-overlay-arrow) - (unwind-protect - (if (or edebug-stop - (memq edebug-execution-mode '(step next)) - (eq arg-mode 'error)) - (progn - ;; (setq edebug-execution-mode 'step) - ;; (edebug-overlay-arrow) ; This doesn't always show up. - (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) - (get-buffer-window edebug-buffer)))) - ;; Remember window-start for edebug-buffer, if still displayed. - (if window - (progn - (setcar edebug-window-data window) - (setcdr edebug-window-data (window-start window))))) - - ;; Save trace window point before restoring outside windows. - ;; Could generalize this for other buffers. - (setq edebug-trace-window (get-buffer-window edebug-trace-buffer)) - (if edebug-trace-window - (setq edebug-trace-window-start - (and edebug-trace-window - (window-start edebug-trace-window)))) - - ;; Restore windows before continuing. - (if edebug-save-windows - (progn - (edebug-set-windows edebug-outside-windows) - - ;; Restore displayed buffer points. - ;; Needed even if restoring windows because - ;; window-points are not restored. (should they be??) - (if edebug-save-displayed-buffer-points - (edebug-set-buffer-points edebug-buffer-points)) - - ;; Unrestore trace window's window-point. - (if edebug-trace-window - (set-window-start edebug-trace-window - edebug-trace-window-start)) - - ;; Unrestore edebug-buffer's window-start, if displayed. - (let ((window (car edebug-window-data))) - (if (and (edebug-window-live-p window) - (eq (window-buffer) edebug-buffer)) - (progn - (set-window-start window (cdr edebug-window-data) - 'no-force) - ;; Unrestore edebug-buffer's window-point. - ;; Needed in addition to setting the buffer point - ;; - otherwise quitting doesn't leave point as is. - ;; But this causes point to not be restored at times. - ;; Also, it may not be a visible window. - ;; (set-window-point window edebug-point) - ))) - - ;; Unrestore edebug-buffer's point. Rerestored below. - ;; (goto-char edebug-point) ;; in edebug-buffer - ) - ;; Since we may be in a save-excursion, in case of quit, - ;; reselect the outside window only. - ;; Only needed if we are not recovering windows?? - (if (edebug-window-live-p edebug-outside-window) - (select-window edebug-outside-window)) - ) ; if edebug-save-windows - - ;; Restore current buffer always, in case application needs it. - (if (buffer-name edebug-outside-buffer) - (set-buffer edebug-outside-buffer)) - ;; Restore point, and mark. - ;; Needed even if restoring windows because - ;; that doesn't restore point and mark in the current buffer. - ;; But don't restore point if edebug-buffer is current buffer. - (if (not (eq edebug-buffer edebug-outside-buffer)) - (goto-char edebug-outside-point)) - (if (marker-buffer (edebug-mark-marker)) - ;; Does zmacs-regions need to be nil while doing set-marker? - (set-marker (edebug-mark-marker) edebug-outside-mark)) - ) ; unwind-protect + (cond + ((eq 'error arg-mode) + ;; Display error message + (setq edebug-execution-mode 'step) + (edebug-overlay-arrow) + (beep) + (if (eq 'quit (car value)) + (message "Quit") + (edebug-report-error value))) + (edebug-break + (cond + (edebug-global-break + (message "Global Break: %s => %s" + edebug-global-break-condition + edebug-global-break-result)) + (edebug-break-condition + (message "Break: %s => %s" + edebug-break-condition + edebug-break-result)) + ((not (eq edebug-execution-mode 'Continue-fast)) + (message "Break")) + (t))) + + (t (message ""))) + + (if (eq 'after arg-mode) + (progn + ;; Display result of previous evaluation. + (if (and edebug-break + (not (eq edebug-execution-mode 'Continue-fast))) + (sit-for edebug-sit-for-seconds)) ; Show message. + (edebug-previous-result))) + + (cond + (edebug-break + (cond + ((eq edebug-execution-mode 'continue) + (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) + (sit-for edebug-sit-for-seconds)) ; Force update and pause. + ((eq edebug-execution-mode 'Trace-fast) + (sit-for 0))) ; Force update and continue. + + (unwind-protect + (if (or edebug-stop + (memq edebug-execution-mode '(step next)) + (eq arg-mode 'error)) + (progn + ;; (setq edebug-execution-mode 'step) + ;; (edebug-overlay-arrow) ; This doesn't always show up. + (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) + (get-buffer-window edebug-buffer)))) + ;; Remember window-start for edebug-buffer, if still displayed. + (if window + (progn + (setcar edebug-window-data window) + (setcdr edebug-window-data (window-start window))))) + + ;; Save trace window point before restoring outside windows. + ;; Could generalize this for other buffers. + (setq edebug-trace-window + (get-buffer-window edebug-trace-buffer)) + (if edebug-trace-window + (setq edebug-trace-window-start + (and edebug-trace-window + (window-start edebug-trace-window)))) + + ;; Restore windows before continuing. + (if edebug-save-windows + (progn + (edebug-set-windows edebug-outside-windows) + + ;; Restore displayed buffer points. + ;; Needed even if restoring windows because + ;; window-points are not restored. (should they be??) + (if edebug-save-displayed-buffer-points + (edebug-set-buffer-points edebug-buffer-points)) + + ;; Unrestore trace window's window-point. + (if edebug-trace-window + (set-window-start edebug-trace-window + edebug-trace-window-start)) + + ;; Unrestore edebug-buffer's window-start, if displayed. + (let ((window (car edebug-window-data))) + (if (and (edebug-window-live-p window) + (eq (window-buffer) edebug-buffer)) + (progn + (set-window-start window (cdr edebug-window-data) + 'no-force) + ;; Unrestore edebug-buffer's window-point. + ;; Needed in addition to setting the buffer point + ;; - otherwise quitting doesn't leave point as is. + ;; But can this causes point to not be restored. + ;; Also, it may not be a visible window. + ;; (set-window-point window edebug-point) + ))) + + ;; Unrestore edebug-buffer's point. Rerestored below. + ;; (goto-char edebug-point) ;; in edebug-buffer + ) + ;; Since we may be in a save-excursion, in case of quit, + ;; reselect the outside window only. + ;; Only needed if we are not recovering windows?? + (if (edebug-window-live-p edebug-outside-window) + (select-window edebug-outside-window)) + ) ; if edebug-save-windows + + ;; Restore current buffer always, in case application needs it. + (if (buffer-name edebug-outside-buffer) + (set-buffer edebug-outside-buffer)) + ;; Restore point, and mark. + ;; Needed even if restoring windows because + ;; that doesn't restore point and mark in the current buffer. + ;; But don't restore point if edebug-buffer is current buffer. + (if (not (eq edebug-buffer edebug-outside-buffer)) + (goto-char edebug-outside-point)) + (if (marker-buffer (edebug-mark-marker)) + ;; Does zmacs-regions need to be nil while doing set-marker? + (set-marker (edebug-mark-marker) edebug-outside-mark)) + )) ; unwind-protect ;; None of the following is done if quit or signal occurs. ;; Restore edebug-buffer's outside point. @@ -2668,11 +2614,6 @@ MSG is printed after `::::} '." (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 - unread-command-events edebug-outside-unread-command-events - 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) (setq-default cursor-in-non-selected-windows edebug-outside-d-c-i-n-s-w) ))) @@ -2690,33 +2631,11 @@ MSG is printed after `::::} '." (defvar edebug-inside-windows) (defvar edebug-interactive-p) -(defvar edebug-outside-map) -(defvar edebug-outside-standard-output) -(defvar edebug-outside-standard-input) -(defvar edebug-outside-current-prefix-arg) -(defvar edebug-outside-last-command) -(defvar edebug-outside-this-command) - -;; Note: here we have defvars for variables that are -;; built-in in certain versions. -;; Each defvar makes a difference -;; in versions where the variable is *not* built-in. - -;; Emacs 18 FIXME - -;; Emacs 19. -(defvar edebug-outside-last-command-event) -(defvar edebug-outside-last-input-event) -(defvar edebug-outside-last-event-frame) -(defvar edebug-outside-last-nonmenu-event) -(defvar edebug-outside-track-mouse) - (defun edebug--recursive-edit (arg-mode) ;; Start up a recursive edit inside of edebug. ;; The current buffer is the edebug-buffer, which is put into edebug-mode. ;; Assume that none of the variables below are buffer-local. - (let ((edebug-buffer-read-only buffer-read-only) - ;; match-data must be done in the outside buffer + (let (;; match-data must be done in the outside buffer (edebug-outside-match-data (with-current-buffer edebug-outside-buffer ; in case match buffer different (match-data))) @@ -2729,30 +2648,6 @@ MSG is printed after `::::} '." ;; The window configuration may be saved and restored ;; during a recursive-edit edebug-inside-windows - - (edebug-outside-map (current-local-map)) - - ;; Save the outside value of executing macro. (here??) - (edebug-outside-executing-macro executing-kbd-macro) - (edebug-outside-pre-command-hook - (edebug-var-status 'pre-command-hook)) - (edebug-outside-post-command-hook - (edebug-var-status 'post-command-hook)) - - (edebug-outside-standard-output standard-output) - (edebug-outside-standard-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-current-prefix-arg current-prefix-arg) - - (edebug-outside-last-input-event last-input-event) - (edebug-outside-last-command-event last-command-event) - (edebug-outside-last-event-frame last-event-frame) - (edebug-outside-last-nonmenu-event last-nonmenu-event) - (edebug-outside-track-mouse track-mouse) ) (unwind-protect @@ -2783,7 +2678,7 @@ MSG is printed after `::::} '." (overriding-local-map nil) (overriding-terminal-local-map nil) - ;; Bind again to outside values. + ;; Bind again to outside values. (debug-on-error edebug-outside-debug-on-error) (debug-on-quit edebug-outside-debug-on-quit) @@ -2804,10 +2699,9 @@ MSG is printed after `::::} '." (not (memq arg-mode '(after error)))) (message "Break")) - (setq buffer-read-only t) (setq signal-hook-function nil) - (edebug-mode) + (edebug-mode 1) (unwind-protect (recursive-edit) ; <<<<<<<<<< Recursive edit @@ -2828,34 +2722,11 @@ MSG is printed after `::::} '." (set-buffer edebug-buffer) (if (memq edebug-execution-mode '(go Go-nonstop)) (edebug-overlay-arrow)) - (setq buffer-read-only edebug-buffer-read-only) - (use-local-map edebug-outside-map) - (remove-hook 'kill-buffer-hook 'edebug-kill-buffer t) - ) + (edebug-mode -1)) ;; gotta have a buffer to let its buffer local variables be set (get-buffer-create " bogus edebug buffer")) ));; inner let - - ;; Reset global vars to outside values, in case they have been changed. - (setq - last-command-event edebug-outside-last-command-event - last-command edebug-outside-last-command - this-command edebug-outside-this-command - current-prefix-arg edebug-outside-current-prefix-arg - last-input-event edebug-outside-last-input-event - last-event-frame edebug-outside-last-event-frame - last-nonmenu-event edebug-outside-last-nonmenu-event - track-mouse edebug-outside-track-mouse - - standard-output edebug-outside-standard-output - standard-input edebug-outside-standard-input - defining-kbd-macro edebug-outside-defining-kbd-macro) - - (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 @@ -3453,6 +3324,9 @@ edebug-mode." (defmacro edebug-outside-excursion (&rest body) "Evaluate an expression list in the outside context. Return the result of the last expression." + ;; Only restores the non-variables context since all the variables let-bound + ;; by Edebug will be properly reset to the appropriate context's value by + ;; backtrace-eval. (declare (debug t)) `(save-excursion ; of current-buffer (if edebug-save-windows @@ -3465,89 +3339,32 @@ Return the result of the last expression." (edebug-set-windows edebug-outside-windows))) (set-buffer edebug-buffer) ; why? - ;; (use-local-map edebug-outside-map) (set-match-data edebug-outside-match-data) ;; Restore outside context. - (let (;; (edebug-inside-map (current-local-map)) ;; restore map?? - (last-command-event edebug-outside-last-command-event) - (last-command edebug-outside-last-command) - (this-command edebug-outside-this-command) - (unread-command-events edebug-outside-unread-command-events) - (current-prefix-arg edebug-outside-current-prefix-arg) - (last-input-event edebug-outside-last-input-event) - (last-event-frame edebug-outside-last-event-frame) - (last-nonmenu-event edebug-outside-last-nonmenu-event) - (track-mouse edebug-outside-track-mouse) - (standard-output edebug-outside-standard-output) - (standard-input edebug-outside-standard-input) - - (executing-kbd-macro edebug-outside-executing-macro) - (defining-kbd-macro edebug-outside-defining-kbd-macro) - ;; Get the values out of the saved statuses. - (pre-command-hook (cdr edebug-outside-pre-command-hook)) - (post-command-hook (cdr edebug-outside-post-command-hook)) - - ;; See edebug-display. - (overlay-arrow-position edebug-outside-o-a-p) - (overlay-arrow-string edebug-outside-o-a-s) - (cursor-in-echo-area edebug-outside-c-i-e-a) - ) - (setq-default cursor-in-non-selected-windows edebug-outside-d-c-i-n-s-w) - (unwind-protect - (with-current-buffer edebug-outside-buffer ; of edebug-buffer - (goto-char edebug-outside-point) - (if (marker-buffer (edebug-mark-marker)) - (set-marker (edebug-mark-marker) edebug-outside-mark)) - ,@body) - - ;; Back to edebug-buffer. Restore rest of inside context. - ;; (use-local-map edebug-inside-map) - (if edebug-save-windows - ;; Restore inside windows. - (edebug-set-windows edebug-inside-windows)) - - ;; Save values that may have been changed. - (setq - edebug-outside-last-command-event last-command-event - edebug-outside-last-command last-command - edebug-outside-this-command this-command - edebug-outside-unread-command-events unread-command-events - edebug-outside-current-prefix-arg current-prefix-arg - edebug-outside-last-input-event last-input-event - edebug-outside-last-event-frame last-event-frame - edebug-outside-last-nonmenu-event last-nonmenu-event - edebug-outside-track-mouse track-mouse - edebug-outside-standard-output standard-output - edebug-outside-standard-input standard-input - - edebug-outside-executing-macro executing-kbd-macro - edebug-outside-defining-kbd-macro defining-kbd-macro - - edebug-outside-o-a-p overlay-arrow-position - edebug-outside-o-a-s overlay-arrow-string - edebug-outside-c-i-e-a cursor-in-echo-area - edebug-outside-d-c-i-n-s-w (default-value - 'cursor-in-non-selected-windows) - ) - - ;; Restore the outside saved values; don't alter - ;; the outside binding loci. - (setcdr edebug-outside-pre-command-hook pre-command-hook) - (setcdr edebug-outside-post-command-hook post-command-hook) - - (setq-default cursor-in-non-selected-windows t) - )) ; let - )) - -(defvar cl-debug-env) ; defined in cl; non-nil when lexical env used. + (setq-default cursor-in-non-selected-windows edebug-outside-d-c-i-n-s-w) + (unwind-protect + (with-current-buffer edebug-outside-buffer ; of edebug-buffer + (goto-char edebug-outside-point) + (if (marker-buffer (edebug-mark-marker)) + (set-marker (edebug-mark-marker) edebug-outside-mark)) + ,@body) + + ;; Back to edebug-buffer. Restore rest of inside context. + ;; (use-local-map edebug-inside-map) + (if edebug-save-windows + ;; Restore inside windows. + (edebug-set-windows edebug-inside-windows)) + + ;; Save values that may have been changed. + (setq edebug-outside-d-c-i-n-s-w + (default-value 'cursor-in-non-selected-windows)) + + ;; Restore the outside saved values; don't alter + ;; the outside binding loci. + (setq-default cursor-in-non-selected-windows t)))) (defun edebug-eval (expr) - ;; Are there cl lexical variables active? - (eval (if (and (bound-and-true-p cl-debug-env) - (fboundp 'cl-macroexpand-all)) - (cl-macroexpand-all expr cl-debug-env) - expr) - lexical-binding)) + (backtrace-eval expr 0 'edebug-after)) (defun edebug-safe-eval (expr) ;; Evaluate EXPR safely. @@ -3773,7 +3590,9 @@ be installed in `emacs-lisp-mode-map'.") (interactive) (describe-function 'edebug-mode)) -(defun edebug-mode () +(defvar edebug--mode-saved-vars nil) + +(define-minor-mode edebug-mode "Mode for Emacs Lisp buffers while in Edebug. In addition to all Emacs Lisp commands (except those that modify the @@ -3807,17 +3626,32 @@ Options: `edebug-on-signal' `edebug-unwrap-results' `edebug-global-break-condition'" + :lighter " *Debugging*" + :keymap edebug-mode-map ;; If the user kills the buffer in which edebug is currently active, ;; exit to top level, because the edebug command loop can't usefully ;; continue running in such a case. - (add-hook 'kill-buffer-hook 'edebug-kill-buffer nil t) - (use-local-map edebug-mode-map)) + ;; + (if (not edebug-mode) + (progn + (while edebug--mode-saved-vars + (let ((setting (pop edebug--mode-saved-vars))) + (if (consp setting) + (set (car setting) (cdr setting)) + (kill-local-variable setting)))) + (remove-hook 'kill-buffer-hook 'edebug-kill-buffer t)) + (pcase-dolist (`(,var . ,val) '((buffer-read-only . t))) + (push + (if (local-variable-p var) (cons var (symbol-value var)) var) + edebug--mode-saved-vars) + (set (make-local-variable var) val)) + ;; Append `edebug-kill-buffer' to the hook to avoid interfering with + ;; other entries that are unguarded against deleted buffer. + (add-hook 'kill-buffer-hook 'edebug-kill-buffer t t))) (defun edebug-kill-buffer () "Used on `kill-buffer-hook' when Edebug is operating in a buffer of Lisp code." - (let (kill-buffer-hook) - (kill-buffer (current-buffer))) - (top-level)) + (run-with-timer 0 nil #'top-level)) ;;; edebug eval list mode @@ -4140,7 +3974,7 @@ reinstrument it." It is removed when you hit any char." ;; This seems not to work with Emacs 18.59. It undoes too far. (interactive) - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (undo-boundary) (edebug-display-freq-count) (setq unread-command-events @@ -4281,7 +4115,7 @@ With prefix argument, make it a temporary breakpoint." (eq (nth 1 (nth 1 frame1)) '()) (eq (nth 1 frame2) 'edebug-enter)) ;; `edebug-enter' calls itself on its first invocation. - (if (eq (nth 1 (internal--called-interactively-p--get-frame i)) + (if (eq (nth 1 (backtrace-frame i 'called-interactively-p)) 'edebug-enter) 2 1))) diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index c8ae3f4bf1a..150724e6484 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -1,6 +1,6 @@ ;;; eieio-base.el --- Base classes for EIEIO. -;;; Copyright (C) 2000-2002, 2004-2005, 2007-2013 Free Software +;;; Copyright (C) 2000-2002, 2004-2005, 2007-2014 Free Software ;;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -31,6 +31,7 @@ ;;; Code: (require 'eieio) +(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! ;;; eieio-instance-inheritor ;; diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el new file mode 100644 index 00000000000..76655caf65a --- /dev/null +++ b/lisp/emacs-lisp/eieio-core.el @@ -0,0 +1,2264 @@ +;;; eieio-core.el --- Core implementation for eieio + +;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Version: 1.4 +;; Keywords: OO, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; The "core" part of EIEIO is the implementation for the object +;; system (such as eieio-defclass, or eieio-defmethod) but not the +;; base classes for the object system, which are defined in EIEIO. +;; +;; See the commentary for eieio.el for more about EIEIO itself. + +;;; Code: + +(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! + +;; Compatibility +(if (fboundp 'compiled-function-arglist) + + ;; XEmacs can only access a compiled functions arglist like this: + (defalias 'eieio-compiled-function-arglist 'compiled-function-arglist) + + ;; Emacs doesn't have this function, but since FUNC is a vector, we can just + ;; grab the appropriate element. + (defun eieio-compiled-function-arglist (func) + "Return the argument list for the compiled function FUNC." + (aref func 0)) + + ) + +(put 'eieio--defalias 'byte-hunk-handler + #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) +(defun eieio--defalias (name body) + "Like `defalias', but with less side-effects. +More specifically, it has no side-effects at all when the new function +definition is the same (`eq') as the old one." + (unless (and (fboundp name) + (eq (symbol-function name) body)) + (defalias name body))) + +;;; +;; A few functions that are better in the official EIEIO src, but +;; used from the core. +(declare-function slot-unbound "eieio") +(declare-function slot-missing "eieio") +(declare-function child-of-class-p "eieio") + + +;;; +;; Variable declarations. +;; +(defvar eieio-hook nil + "This hook is executed, then cleared each time `defclass' is called.") + +(defvar eieio-error-unsupported-class-tags nil + "Non-nil to throw an error if an encountered tag is unsupported. +This may prevent classes from CLOS applications from being used with EIEIO +since EIEIO does not support all CLOS tags.") + +(defvar eieio-skip-typecheck nil + "If non-nil, skip all slot typechecking. +Set this to t permanently if a program is functioning well to get a +small speed increase. This variable is also used internally to handle +default setting for optimization purposes.") + +(defvar eieio-optimize-primary-methods-flag t + "Non-nil means to optimize the method dispatch on primary methods.") + +(defvar eieio-initializing-object nil + "Set to non-nil while initializing an object.") + +(defconst eieio-unbound + (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) + eieio-unbound + (make-symbol "unbound")) + "Uninterned symbol representing an unbound slot in an object.") + +;; This is a bootstrap for eieio-default-superclass so it has a value +;; while it is being built itself. +(defvar eieio-default-superclass nil) + +;;; +;; Class currently in scope. +;; +;; When invoking methods, the running method needs to know which class +;; is currently in scope. Generally this is the class of the method +;; being called, but 'call-next-method' needs to query this state, +;; and change it to be then next super class up. +;; +;; Thus, the scoped class is a stack that needs to be managed. + +(defvar eieio--scoped-class-stack nil + "A stack of the classes currently in scope during method invocation.") + +(defun eieio--scoped-class () + "Return the class currently in scope, or nil." + (car-safe eieio--scoped-class-stack)) + +(defmacro eieio--with-scoped-class (class &rest forms) + "Set CLASS as the currently scoped class while executing FORMS." + `(unwind-protect + (progn + (push ,class eieio--scoped-class-stack) + ,@forms) + (pop eieio--scoped-class-stack))) +(put 'eieio--with-scoped-class 'lisp-indent-function 1) + +;;; +;; Field Accessors +;; +(defmacro eieio--define-field-accessors (prefix fields) + (declare (indent 1)) + (let ((index 0) + (defs '())) + (dolist (field fields) + (let ((doc (if (listp field) + (prog1 (cadr field) (setq field (car field)))))) + (push `(defmacro ,(intern (format "eieio--%s-%s" prefix field)) (x) + ,@(if doc (list (format (if (string-match "\n" doc) + "Return %s" "Return %s of a %s.") + doc prefix))) + (list 'aref x ,index)) + defs) + (setq index (1+ index)))) + `(eval-and-compile + ,@(nreverse defs) + (defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index)))) + +(eieio--define-field-accessors class + (-unused-0 ;;FIXME: not sure, but at least there was no accessor! + (symbol "symbol (self-referencing)") + parent children + (symbol-obarray "obarray permitting fast access to variable position indexes") + ;; @todo + ;; the word "public" here is leftovers from the very first version. + ;; Get rid of it! + (public-a "class attribute index") + (public-d "class attribute defaults index") + (public-doc "class documentation strings for attributes") + (public-type "class type for a slot") + (public-custom "class custom type for a slot") + (public-custom-label "class custom group for a slot") + (public-custom-group "class custom group for a slot") + (public-printer "printer for a slot") + (protection "protection for a slot") + (initarg-tuples "initarg tuples list") + (class-allocation-a "class allocated attributes") + (class-allocation-doc "class allocated documentation") + (class-allocation-type "class allocated value type") + (class-allocation-custom "class allocated custom descriptor") + (class-allocation-custom-label "class allocated custom descriptor") + (class-allocation-custom-group "class allocated custom group") + (class-allocation-printer "class allocated printer for a slot") + (class-allocation-protection "class allocated protection list") + (class-allocation-values "class allocated value vector") + (default-object-cache "what a newly created object would look like. +This will speed up instantiation time as only a `copy-sequence' will +be needed, instead of looping over all the values and setting them +from the default.") + (options "storage location of tagged class options. +Stored outright without modifications or stripping."))) + +(eieio--define-field-accessors object + (-unused-0 ;;FIXME: not sure, but at least there was no accessor! + (class "class struct defining OBJ") + name)) + +;; FIXME: The constants below should have an `eieio-' prefix added!! + +(defconst method-static 0 "Index into :static tag on a method.") +(defconst method-before 1 "Index into :before tag on a method.") +(defconst method-primary 2 "Index into :primary tag on a method.") +(defconst method-after 3 "Index into :after tag on a method.") +(defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.") +(defconst method-generic-before 4 "Index into generic :before tag on a method.") +(defconst method-generic-primary 5 "Index into generic :primary tag on a method.") +(defconst method-generic-after 6 "Index into generic :after tag on a method.") +(defconst method-num-slots 7 "Number of indexes into a method's vector.") + +(defsubst eieio-specialized-key-to-generic-key (key) + "Convert a specialized KEY into a generic method key." + (cond ((eq key method-static) 0) ;; don't convert + ((< key method-num-lists) (+ key 3)) ;; The conversion + (t key) ;; already generic.. maybe. + )) + + +;;; Important macros used internally in eieio. +;; +(defmacro eieio--check-type (type obj) + (unless (symbolp obj) + (error "eieio--check-type wants OBJ to be a variable")) + `(if (not ,(cond + ((eq 'or (car-safe type)) + `(or ,@(mapcar (lambda (type) `(,type ,obj)) (cdr type)))) + (t `(,type ,obj)))) + (signal 'wrong-type-argument (list ',type ,obj)))) + +(defmacro class-v (class) + "Internal: Return the class vector from the CLASS symbol." + ;; No check: If eieio gets this far, it has probably been checked already. + `(get ,class 'eieio-class-definition)) + +(defmacro class-p (class) + "Return t if CLASS is a valid class vector. +CLASS is a symbol." + ;; this new method is faster since it doesn't waste time checking lots of + ;; things. + `(condition-case nil + (eq (aref (class-v ,class) 0) 'defclass) + (error nil))) + +(defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS." + (eieio--check-type class-p class) + ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, + ;; and I wanted a string. Arg! + (format "#<class %s>" (symbol-name class))) +(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") + +(defmacro eieio-class-parents-fast (class) + "Return parent classes to CLASS with no check." + `(eieio--class-parent (class-v ,class))) + +(defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check." + `(eieio--class-children (class-v ,class))) + +(defmacro same-class-fast-p (obj class) + "Return t if OBJ is of class-type CLASS with no error checking." + `(eq (eieio--object-class ,obj) ,class)) + +(defmacro class-constructor (class) + "Return the symbol representing the constructor of CLASS." + `(eieio--class-symbol (class-v ,class))) + +(defmacro generic-p (method) + "Return t if symbol METHOD is a generic function. +Only methods have the symbol `eieio-method-obarray' as a property +\(which contains a list of all bindings to that method type.)" + `(and (fboundp ,method) (get ,method 'eieio-method-obarray))) + +(defun generic-primary-only-p (method) + "Return t if symbol METHOD is a generic function with only primary methods. +Only methods have the symbol `eieio-method-obarray' as a property (which +contains a list of all bindings to that method type.) +Methods with only primary implementations are executed in an optimized way." + (and (generic-p method) + (let ((M (get method 'eieio-method-tree))) + (and (< 0 (length (aref M method-primary))) + (not (aref M method-static)) + (not (aref M method-before)) + (not (aref M method-after)) + (not (aref M method-generic-before)) + (not (aref M method-generic-primary)) + (not (aref M method-generic-after)))) + )) + +(defun generic-primary-only-one-p (method) + "Return t if symbol METHOD is a generic function with only primary methods. +Only methods have the symbol `eieio-method-obarray' as a property (which +contains a list of all bindings to that method type.) +Methods with only primary implementations are executed in an optimized way." + (and (generic-p method) + (let ((M (get method 'eieio-method-tree))) + (and (= 1 (length (aref M method-primary))) + (not (aref M method-static)) + (not (aref M method-before)) + (not (aref M method-after)) + (not (aref M method-generic-before)) + (not (aref M method-generic-primary)) + (not (aref M method-generic-after)))) + )) + +(defmacro class-option-assoc (list option) + "Return from LIST the found OPTION, or nil if it doesn't exist." + `(car-safe (cdr (memq ,option ,list)))) + +(defmacro class-option (class option) + "Return the value stored for CLASS' OPTION. +Return nil if that option doesn't exist." + `(class-option-assoc (eieio--class-options (class-v ,class)) ',option)) + +(defmacro eieio-object-p (obj) + "Return non-nil if OBJ is an EIEIO object." + `(condition-case nil + (let ((tobj ,obj)) + (and (eq (aref tobj 0) 'object) + (class-p (eieio--object-class tobj)))) + (error nil))) +(defalias 'object-p 'eieio-object-p) + +(defmacro class-abstract-p (class) + "Return non-nil if CLASS is abstract. +Abstract classes cannot be instantiated." + `(class-option ,class :abstract)) + +(defmacro class-method-invocation-order (class) + "Return the invocation order of CLASS. +Abstract classes cannot be instantiated." + `(or (class-option ,class :method-invocation-order) + :breadth-first)) + + + +;;; +;; Class Creation + +(defvar eieio-defclass-autoload-map (make-vector 7 nil) + "Symbol map of superclasses we find in autoloads.") + +;; We autoload this because it's used in `make-autoload'. +;;;###autoload +(defun eieio-defclass-autoload (cname superclasses filename doc) + "Create autoload symbols for the EIEIO class CNAME. +SUPERCLASSES are the superclasses that CNAME inherits from. +DOC is the docstring for CNAME. +This function creates a mock-class for CNAME and adds it into +SUPERCLASSES as children. +It creates an autoload function for CNAME's constructor." + ;; Assume we've already debugged inputs. + + (let* ((oldc (when (class-p cname) (class-v cname))) + (newc (make-vector eieio--class-num-slots nil)) + ) + (if oldc + nil ;; Do nothing if we already have this class. + + ;; Create the class in NEWC, but don't fill anything else in. + (aset newc 0 'defclass) + (setf (eieio--class-symbol newc) cname) + + (let ((clear-parent nil)) + ;; No parents? + (when (not superclasses) + (setq superclasses '(eieio-default-superclass) + clear-parent t) + ) + + ;; Hook our new class into the existing structures so we can + ;; autoload it later. + (dolist (SC superclasses) + + + ;; TODO - If we create an autoload that is in the map, that + ;; map needs to be cleared! + + + ;; Does our parent exist? + (if (not (class-p SC)) + + ;; Create a symbol for this parent, and then store this + ;; parent on that symbol. + (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map))) + (if (not (boundp sym)) + (set sym (list cname)) + (add-to-list sym cname)) + ) + + ;; We have a parent, save the child in there. + (when (not (member cname (eieio--class-children (class-v SC)))) + (setf (eieio--class-children (class-v SC)) + (cons cname (eieio--class-children (class-v SC)))))) + + ;; save parent in child + (setf (eieio--class-parent newc) (cons SC (eieio--class-parent newc))) + ) + + ;; turn this into a usable self-pointing symbol + (set cname cname) + + ;; Store the new class vector definition into the symbol. We need to + ;; do this first so that we can call defmethod for the accessor. + ;; The vector will be updated by the following while loop and will not + ;; need to be stored a second time. + (put cname 'eieio-class-definition newc) + + ;; Clear the parent + (if clear-parent (setf (eieio--class-parent newc) nil)) + + ;; Create an autoload on top of our constructor function. + (autoload cname filename doc nil nil) + (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) + (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) + (autoload (intern (concat (symbol-name cname) "-list-p")) filename "" nil nil) + + )))) + +(defsubst eieio-class-un-autoload (cname) + "If class CNAME is in an autoload state, load its file." + (when (eq (car-safe (symbol-function cname)) 'autoload) + (load-library (car (cdr (symbol-function cname)))))) + +(defun eieio-defclass (cname superclasses slots options-and-doc) + ;; FIXME: Most of this should be moved to the `defclass' macro. + "Define CNAME as a new subclass of SUPERCLASSES. +SLOTS are the slots residing in that class definition, and options or +documentation OPTIONS-AND-DOC is the toplevel documentation for this class. +See `defclass' for more information." + ;; Run our eieio-hook each time, and clear it when we are done. + ;; This way people can add hooks safely if they want to modify eieio + ;; or add definitions when eieio is loaded or something like that. + (run-hooks 'eieio-hook) + (setq eieio-hook nil) + + (eieio--check-type listp superclasses) + + (let* ((pname superclasses) + (newc (make-vector eieio--class-num-slots nil)) + (oldc (when (class-p cname) (class-v cname))) + (groups nil) ;; list of groups id'd from slots + (options nil) + (clearparent nil)) + + (aset newc 0 'defclass) + (setf (eieio--class-symbol newc) cname) + + ;; If this class already existed, and we are updating its structure, + ;; make sure we keep the old child list. This can cause bugs, but + ;; if no new slots are created, it also saves time, and prevents + ;; method table breakage, particularly when the users is only + ;; byte compiling an EIEIO file. + (if oldc + (setf (eieio--class-children newc) (eieio--class-children oldc)) + ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. + ;; This is like the above, but deals with autoloads nicely. + (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) + (when sym + (condition-case nil + (setf (eieio--class-children newc) (symbol-value sym)) + (error nil)) + (unintern (symbol-name cname) eieio-defclass-autoload-map) + )) + ) + + (cond ((and (stringp (car options-and-doc)) + (/= 1 (% (length options-and-doc) 2))) + (error "Too many arguments to `defclass'")) + ((and (symbolp (car options-and-doc)) + (/= 0 (% (length options-and-doc) 2))) + (error "Too many arguments to `defclass'")) + ) + + (setq options + (if (stringp (car options-and-doc)) + (cons :documentation options-and-doc) + options-and-doc)) + + (if pname + (progn + (while pname + (if (and (car pname) (symbolp (car pname))) + (if (not (class-p (car pname))) + ;; bad class + (error "Given parent class %s is not a class" (car pname)) + ;; good parent class... + ;; save new child in parent + (when (not (member cname (eieio--class-children (class-v (car pname))))) + (setf (eieio--class-children (class-v (car pname))) + (cons cname (eieio--class-children (class-v (car pname)))))) + ;; Get custom groups, and store them into our local copy. + (mapc (lambda (g) (pushnew g groups :test #'equal)) + (class-option (car pname) :custom-groups)) + ;; save parent in child + (setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc)))) + (error "Invalid parent class %s" pname)) + (setq pname (cdr pname))) + ;; Reverse the list of our parents so that they are prioritized in + ;; the same order as specified in the code. + (setf (eieio--class-parent newc) (nreverse (eieio--class-parent newc))) ) + ;; If there is nothing to loop over, then inherit from the + ;; default superclass. + (unless (eq cname 'eieio-default-superclass) + ;; adopt the default parent here, but clear it later... + (setq clearparent t) + ;; save new child in parent + (if (not (member cname (eieio--class-children (class-v 'eieio-default-superclass)))) + (setf (eieio--class-children (class-v 'eieio-default-superclass)) + (cons cname (eieio--class-children (class-v 'eieio-default-superclass))))) + ;; save parent in child + (setf (eieio--class-parent newc) (list eieio-default-superclass)))) + + ;; turn this into a usable self-pointing symbol + (set cname cname) + + ;; These two tests must be created right away so we can have self- + ;; referencing classes. ei, a class whose slot can contain only + ;; pointers to itself. + + ;; Create the test function + (let ((csym (intern (concat (symbol-name cname) "-p")))) + (fset csym + (list 'lambda (list 'obj) + (format "Test OBJ to see if it an object of type %s" cname) + (list 'and '(eieio-object-p obj) + (list 'same-class-p 'obj cname))))) + + ;; Make sure the method invocation order is a valid value. + (let ((io (class-option-assoc options :method-invocation-order))) + (when (and io (not (member io '(:depth-first :breadth-first :c3)))) + (error "Method invocation order %s is not allowed" io) + )) + + ;; Create a handy child test too + (let ((csym (intern (concat (symbol-name cname) "-child-p")))) + (fset csym + `(lambda (obj) + ,(format + "Test OBJ to see if it an object is a child of type %s" + cname) + (and (eieio-object-p obj) + (object-of-class-p obj ,cname)))) + + ;; Create a handy list of the class test too + (let ((csym (intern (concat (symbol-name cname) "-list-p")))) + (fset csym + `(lambda (obj) + ,(format + "Test OBJ to see if it a list of objects which are a child of type %s" + cname) + (when (listp obj) + (let ((ans t)) ;; nil is valid + ;; Loop over all the elements of the input list, test + ;; each to make sure it is a child of the desired object class. + (while (and obj ans) + (setq ans (and (eieio-object-p (car obj)) + (object-of-class-p (car obj) ,cname))) + (setq obj (cdr obj))) + ans))))) + + ;; When using typep, (typep OBJ 'myclass) returns t for objects which + ;; are subclasses of myclass. For our predicates, however, it is + ;; important for EIEIO to be backwards compatible, where + ;; myobject-p, and myobject-child-p are different. + ;; "cl" uses this technique to specify symbols with specific typep + ;; test, so we can let typep have the CLOS documented behavior + ;; while keeping our above predicate clean. + + ;; It would be cleaner to use `defsetf' here, but that requires cl + ;; at runtime. + (put cname 'cl-deftype-handler + (list 'lambda () `(list 'satisfies (quote ,csym))))) + + ;; Before adding new slots, let's add all the methods and classes + ;; in from the parent class. + (eieio-copy-parents-into-subclass newc superclasses) + + ;; Store the new class vector definition into the symbol. We need to + ;; do this first so that we can call defmethod for the accessor. + ;; The vector will be updated by the following while loop and will not + ;; need to be stored a second time. + (put cname 'eieio-class-definition newc) + + ;; Query each slot in the declaration list and mangle into the + ;; class structure I have defined. + (while slots + (let* ((slot1 (car slots)) + (name (car slot1)) + (slot (cdr slot1)) + (acces (plist-get slot ':accessor)) + (init (or (plist-get slot ':initform) + (if (member ':initform slot) nil + eieio-unbound))) + (initarg (plist-get slot ':initarg)) + (docstr (plist-get slot ':documentation)) + (prot (plist-get slot ':protection)) + (reader (plist-get slot ':reader)) + (writer (plist-get slot ':writer)) + (alloc (plist-get slot ':allocation)) + (type (plist-get slot ':type)) + (custom (plist-get slot ':custom)) + (label (plist-get slot ':label)) + (customg (plist-get slot ':group)) + (printer (plist-get slot ':printer)) + + (skip-nil (class-option-assoc options :allow-nil-initform)) + ) + + (if eieio-error-unsupported-class-tags + (let ((tmp slot)) + (while tmp + (if (not (member (car tmp) '(:accessor + :initform + :initarg + :documentation + :protection + :reader + :writer + :allocation + :type + :custom + :label + :group + :printer + :allow-nil-initform + :custom-groups))) + (signal 'invalid-slot-type (list (car tmp)))) + (setq tmp (cdr (cdr tmp)))))) + + ;; Clean up the meaning of protection. + (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil)) + ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) + ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) + ((eq prot nil) nil) + (t (signal 'invalid-slot-type (list ':protection prot)))) + + ;; Make sure the :allocation parameter has a valid value. + (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) + (signal 'invalid-slot-type (list ':allocation alloc))) + + ;; The default type specifier is supposed to be t, meaning anything. + (if (not type) (setq type t)) + + ;; Label is nil, or a string + (if (not (or (null label) (stringp label))) + (signal 'invalid-slot-type (list ':label label))) + + ;; Is there an initarg, but allocation of class? + (if (and initarg (eq alloc :class)) + (message "Class allocated slots do not need :initarg")) + + ;; intern the symbol so we can use it blankly + (if initarg (set initarg initarg)) + + ;; The customgroup should be a list of symbols + (cond ((null customg) + (setq customg '(default))) + ((not (listp customg)) + (setq customg (list customg)))) + ;; The customgroup better be a symbol, or list of symbols. + (mapc (lambda (cg) + (if (not (symbolp cg)) + (signal 'invalid-slot-type (list ':group cg)))) + customg) + + ;; First up, add this slot into our new class. + (eieio-add-new-slot newc name init docstr type custom label customg printer + prot initarg alloc 'defaultoverride skip-nil) + + ;; We need to id the group, and store them in a group list attribute. + (mapc (lambda (cg) (pushnew cg groups :test 'equal)) customg) + + ;; Anyone can have an accessor function. This creates a function + ;; of the specified name, and also performs a `defsetf' if applicable + ;; so that users can `setf' the space returned by this function. + (if acces + (progn + (eieio--defmethod + acces (if (eq alloc :class) :static :primary) cname + `(lambda (this) + ,(format + "Retrieves the slot `%s' from an object of class `%s'" + name cname) + (if (slot-boundp this ',name) + (eieio-oref this ',name) + ;; Else - Some error? nil? + nil))) + + (if (fboundp 'gv-define-setter) + ;; FIXME: We should move more of eieio-defclass into the + ;; defclass macro so we don't have to use `eval' and require + ;; `gv' at run-time. + (eval `(gv-define-setter ,acces (eieio--store eieio--object) + (list 'eieio-oset eieio--object '',name + eieio--store))) + ;; Provide a setf method. It would be cleaner to use + ;; defsetf, but that would require CL at runtime. + (put acces 'setf-method + `(lambda (widget) + (let* ((--widget-sym-- (make-symbol "--widget--")) + (--store-sym-- (make-symbol "--store--"))) + (list + (list --widget-sym--) + (list widget) + (list --store-sym--) + (list 'eieio-oset --widget-sym-- '',name + --store-sym--) + (list 'getfoo --widget-sym--)))))))) + + ;; If a writer is defined, then create a generic method of that + ;; name whose purpose is to set the value of the slot. + (if writer + (eieio--defmethod + writer nil cname + `(lambda (this value) + ,(format "Set the slot `%s' of an object of class `%s'" + name cname) + (setf (slot-value this ',name) value)))) + ;; If a reader is defined, then create a generic method + ;; of that name whose purpose is to access this slot value. + (if reader + (eieio--defmethod + reader nil cname + `(lambda (this) + ,(format "Access the slot `%s' from object of class `%s'" + name cname) + (slot-value this ',name)))) + ) + (setq slots (cdr slots))) + + ;; Now that everything has been loaded up, all our lists are backwards! + ;; Fix that up now. + (setf (eieio--class-public-a newc) (nreverse (eieio--class-public-a newc))) + (setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc))) + (setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc newc))) + (setf (eieio--class-public-type newc) + (apply 'vector (nreverse (eieio--class-public-type newc)))) + (setf (eieio--class-public-custom newc) (nreverse (eieio--class-public-custom newc))) + (setf (eieio--class-public-custom-label newc) (nreverse (eieio--class-public-custom-label newc))) + (setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc))) + (setf (eieio--class-public-printer newc) (nreverse (eieio--class-public-printer newc))) + (setf (eieio--class-protection newc) (nreverse (eieio--class-protection newc))) + (setf (eieio--class-initarg-tuples newc) (nreverse (eieio--class-initarg-tuples newc))) + + ;; The storage for class-class-allocation-type needs to be turned into + ;; a vector now. + (setf (eieio--class-class-allocation-type newc) + (apply 'vector (eieio--class-class-allocation-type newc))) + + ;; Also, take class allocated values, and vectorize them for speed. + (setf (eieio--class-class-allocation-values newc) + (apply 'vector (eieio--class-class-allocation-values newc))) + + ;; Attach slot symbols into an obarray, and store the index of + ;; this slot as the variable slot in this new symbol. We need to + ;; know about primes, because obarrays are best set in vectors of + ;; prime number length, and we also need to make our vector small + ;; to save space, and also optimal for the number of items we have. + (let* ((cnt 0) + (pubsyms (eieio--class-public-a newc)) + (prots (eieio--class-protection newc)) + (l (length pubsyms)) + (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47 + 53 59 61 67 71 73 79 83 89 97 101 ))) + (while (and primes (< (car primes) l)) + (setq primes (cdr primes))) + (car primes))) + (oa (make-vector vl 0)) + (newsym)) + (while pubsyms + (setq newsym (intern (symbol-name (car pubsyms)) oa)) + (set newsym cnt) + (setq cnt (1+ cnt)) + (if (car prots) (put newsym 'protection (car prots))) + (setq pubsyms (cdr pubsyms) + prots (cdr prots))) + (setf (eieio--class-symbol-obarray newc) oa) + ) + + ;; Create the constructor function + (if (class-option-assoc options :abstract) + ;; Abstract classes cannot be instantiated. Say so. + (let ((abs (class-option-assoc options :abstract))) + (if (not (stringp abs)) + (setq abs (format "Class %s is abstract" cname))) + (fset cname + `(lambda (&rest stuff) + ,(format "You cannot create a new object of type %s" cname) + (error ,abs)))) + + ;; Non-abstract classes need a constructor. + (fset cname + `(lambda (newname &rest slots) + ,(format "Create a new object with name NAME of class type %s" cname) + (apply 'constructor ,cname newname slots))) + ) + + ;; Set up a specialized doc string. + ;; Use stored value since it is calculated in a non-trivial way + (put cname 'variable-documentation + (class-option-assoc options :documentation)) + + ;; Save the file location where this class is defined. + (let ((fname (if load-in-progress + load-file-name + buffer-file-name))) + (when fname + (when (string-match "\\.elc\\'" fname) + (setq fname (substring fname 0 (1- (length fname))))) + (put cname 'class-location fname))) + + ;; We have a list of custom groups. Store them into the options. + (let ((g (class-option-assoc options :custom-groups))) + (mapc (lambda (cg) (pushnew cg g :test 'equal)) groups) + (if (memq :custom-groups options) + (setcar (cdr (memq :custom-groups options)) g) + (setq options (cons :custom-groups (cons g options))))) + + ;; Set up the options we have collected. + (setf (eieio--class-options newc) options) + + ;; if this is a superclass, clear out parent (which was set to the + ;; default superclass eieio-default-superclass) + (if clearparent (setf (eieio--class-parent newc) nil)) + + ;; Create the cached default object. + (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) 3) + nil))) + (aset cache 0 'object) + (setf (eieio--object-class cache) cname) + (setf (eieio--object-name cache) 'default-cache-object) + (let ((eieio-skip-typecheck t)) + ;; All type-checking has been done to our satisfaction + ;; before this call. Don't waste our time in this call.. + (eieio-set-defaults cache t)) + (setf (eieio--class-default-object-cache newc) cache)) + + ;; Return our new class object + ;; newc + cname + )) + +(defsubst eieio-eval-default-p (val) + "Whether the default value VAL should be evaluated for use." + (and (consp val) (symbolp (car val)) (fboundp (car val)))) + +(defun eieio-perform-slot-validation-for-default (slot spec value skipnil) + "For SLOT, signal if SPEC does not match VALUE. +If SKIPNIL is non-nil, then if VALUE is nil return t instead." + (if (and (not (eieio-eval-default-p value)) + (not eieio-skip-typecheck) + (not (and skipnil (null value))) + (not (eieio-perform-slot-validation spec value))) + (signal 'invalid-slot-type (list slot spec value)))) + +(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc + &optional defaultoverride skipnil) + "Add into NEWC attribute A. +If A already exists in NEWC, then do nothing. If it doesn't exist, +then also add in D (default), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg. +Argument ALLOC specifies if the slot is allocated per instance, or per class. +If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, +we must override its value for a default. +Optional argument SKIPNIL indicates if type checking should be skipped +if default value is nil." + ;; Make sure we duplicate those items that are sequences. + (condition-case nil + (if (sequencep d) (setq d (copy-sequence d))) + ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work. + (error nil)) + (if (sequencep type) (setq type (copy-sequence type))) + (if (sequencep cust) (setq cust (copy-sequence cust))) + (if (sequencep custg) (setq custg (copy-sequence custg))) + + ;; To prevent override information w/out specification of storage, + ;; we need to do this little hack. + (if (member a (eieio--class-class-allocation-a newc)) (setq alloc ':class)) + + (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) + ;; In this case, we modify the INSTANCE version of a given slot. + + (progn + + ;; Only add this element if it is so-far unique + (if (not (member a (eieio--class-public-a newc))) + (progn + (eieio-perform-slot-validation-for-default a type d skipnil) + (setf (eieio--class-public-a newc) (cons a (eieio--class-public-a newc))) + (setf (eieio--class-public-d newc) (cons d (eieio--class-public-d newc))) + (setf (eieio--class-public-doc newc) (cons doc (eieio--class-public-doc newc))) + (setf (eieio--class-public-type newc) (cons type (eieio--class-public-type newc))) + (setf (eieio--class-public-custom newc) (cons cust (eieio--class-public-custom newc))) + (setf (eieio--class-public-custom-label newc) (cons label (eieio--class-public-custom-label newc))) + (setf (eieio--class-public-custom-group newc) (cons custg (eieio--class-public-custom-group newc))) + (setf (eieio--class-public-printer newc) (cons print (eieio--class-public-printer newc))) + (setf (eieio--class-protection newc) (cons prot (eieio--class-protection newc))) + (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) + ) + ;; When defaultoverride is true, we are usually adding new local + ;; attributes which must override the default value of any slot + ;; passed in by one of the parent classes. + (when defaultoverride + ;; There is a match, and we must override the old value. + (let* ((ca (eieio--class-public-a newc)) + (np (member a ca)) + (num (- (length ca) (length np))) + (dp (if np (nthcdr num (eieio--class-public-d newc)) + nil)) + (tp (if np (nth num (eieio--class-public-type newc)))) + ) + (if (not np) + (error "EIEIO internal error overriding default value for %s" + a) + ;; If type is passed in, is it the same? + (if (not (eq type t)) + (if (not (equal type tp)) + (error + "Child slot type `%s' does not match inherited type `%s' for `%s'" + type tp a))) + ;; If we have a repeat, only update the initarg... + (unless (eq d eieio-unbound) + (eieio-perform-slot-validation-for-default a tp d skipnil) + (setcar dp d)) + ;; If we have a new initarg, check for it. + (when init + (let* ((inits (eieio--class-initarg-tuples newc)) + (inita (rassq a inits))) + ;; Replace the CAR of the associate INITA. + ;;(message "Initarg: %S replace %s" inita init) + (setcar inita init) + )) + + ;; PLN Tue Jun 26 11:57:06 2007 : The protection is + ;; checked and SHOULD match the superclass + ;; protection. Otherwise an error is thrown. However + ;; I wonder if a more flexible schedule might be + ;; implemented. + ;; + ;; EML - We used to have (if prot... here, + ;; but a prot of 'nil means public. + ;; + (let ((super-prot (nth num (eieio--class-protection newc))) + ) + (if (not (eq prot super-prot)) + (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" + prot super-prot a))) + ;; End original PLN + + ;; PLN Tue Jun 26 11:57:06 2007 : + ;; Do a non redundant combination of ancient custom + ;; groups and new ones. + (when custg + (let* ((groups + (nthcdr num (eieio--class-public-custom-group newc))) + (list1 (car groups)) + (list2 (if (listp custg) custg (list custg)))) + (if (< (length list1) (length list2)) + (setq list1 (prog1 list2 (setq list2 list1)))) + (dolist (elt list2) + (unless (memq elt list1) + (push elt list1))) + (setcar groups list1))) + ;; End PLN + + ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is + ;; set, simply replaces the old one. + (when cust + ;; (message "Custom type redefined to %s" cust) + (setcar (nthcdr num (eieio--class-public-custom newc)) cust)) + + ;; If a new label is specified, it simply replaces + ;; the old one. + (when label + ;; (message "Custom label redefined to %s" label) + (setcar (nthcdr num (eieio--class-public-custom-label newc)) label)) + ;; End PLN + + ;; PLN Sat Jun 30 17:24:42 2007 : when a new + ;; doc is specified, simply replaces the old one. + (when doc + ;;(message "Documentation redefined to %s" doc) + (setcar (nthcdr num (eieio--class-public-doc newc)) + doc)) + ;; End PLN + + ;; If a new printer is specified, it simply replaces + ;; the old one. + (when print + ;; (message "printer redefined to %s" print) + (setcar (nthcdr num (eieio--class-public-printer newc)) print)) + + ))) + )) + + ;; CLASS ALLOCATED SLOTS + (let ((value (eieio-default-eval-maybe d))) + (if (not (member a (eieio--class-class-allocation-a newc))) + (progn + (eieio-perform-slot-validation-for-default a type value skipnil) + ;; Here we have found a :class version of a slot. This + ;; requires a very different approach. + (setf (eieio--class-class-allocation-a newc) (cons a (eieio--class-class-allocation-a newc))) + (setf (eieio--class-class-allocation-doc newc) (cons doc (eieio--class-class-allocation-doc newc))) + (setf (eieio--class-class-allocation-type newc) (cons type (eieio--class-class-allocation-type newc))) + (setf (eieio--class-class-allocation-custom newc) (cons cust (eieio--class-class-allocation-custom newc))) + (setf (eieio--class-class-allocation-custom-label newc) (cons label (eieio--class-class-allocation-custom-label newc))) + (setf (eieio--class-class-allocation-custom-group newc) (cons custg (eieio--class-class-allocation-custom-group newc))) + (setf (eieio--class-class-allocation-protection newc) (cons prot (eieio--class-class-allocation-protection newc))) + ;; Default value is stored in the 'values section, since new objects + ;; can't initialize from this element. + (setf (eieio--class-class-allocation-values newc) (cons value (eieio--class-class-allocation-values newc)))) + (when defaultoverride + ;; There is a match, and we must override the old value. + (let* ((ca (eieio--class-class-allocation-a newc)) + (np (member a ca)) + (num (- (length ca) (length np))) + (dp (if np + (nthcdr num + (eieio--class-class-allocation-values newc)) + nil)) + (tp (if np (nth num (eieio--class-class-allocation-type newc)) + nil))) + (if (not np) + (error "EIEIO internal error overriding default value for %s" + a) + ;; If type is passed in, is it the same? + (if (not (eq type t)) + (if (not (equal type tp)) + (error + "Child slot type `%s' does not match inherited type `%s' for `%s'" + type tp a))) + ;; EML - Note: the only reason to override a class bound slot + ;; is to change the default, so allow unbound in. + + ;; If we have a repeat, only update the value... + (eieio-perform-slot-validation-for-default a tp value skipnil) + (setcar dp value)) + + ;; PLN Tue Jun 26 11:57:06 2007 : The protection is + ;; checked and SHOULD match the superclass + ;; protection. Otherwise an error is thrown. However + ;; I wonder if a more flexible schedule might be + ;; implemented. + (let ((super-prot + (car (nthcdr num (eieio--class-class-allocation-protection newc))))) + (if (not (eq prot super-prot)) + (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" + prot super-prot a))) + ;; Do a non redundant combination of ancient custom groups + ;; and new ones. + (when custg + (let* ((groups + (nthcdr num (eieio--class-class-allocation-custom-group newc))) + (list1 (car groups)) + (list2 (if (listp custg) custg (list custg)))) + (if (< (length list1) (length list2)) + (setq list1 (prog1 list2 (setq list2 list1)))) + (dolist (elt list2) + (unless (memq elt list1) + (push elt list1))) + (setcar groups list1))) + + ;; PLN Sat Jun 30 17:24:42 2007 : when a new + ;; doc is specified, simply replaces the old one. + (when doc + ;;(message "Documentation redefined to %s" doc) + (setcar (nthcdr num (eieio--class-class-allocation-doc newc)) + doc)) + ;; End PLN + + ;; If a new printer is specified, it simply replaces + ;; the old one. + (when print + ;; (message "printer redefined to %s" print) + (setcar (nthcdr num (eieio--class-class-allocation-printer newc)) print)) + + )) + )) + )) + +(defun eieio-copy-parents-into-subclass (newc parents) + "Copy into NEWC the slots of PARENTS. +Follow the rules of not overwriting early parents when applying to +the new child class." + (let ((ps (eieio--class-parent newc)) + (sn (class-option-assoc (eieio--class-options newc) + ':allow-nil-initform))) + (while ps + ;; First, duplicate all the slots of the parent. + (let ((pcv (class-v (car ps)))) + (let ((pa (eieio--class-public-a pcv)) + (pd (eieio--class-public-d pcv)) + (pdoc (eieio--class-public-doc pcv)) + (ptype (eieio--class-public-type pcv)) + (pcust (eieio--class-public-custom pcv)) + (plabel (eieio--class-public-custom-label pcv)) + (pcustg (eieio--class-public-custom-group pcv)) + (printer (eieio--class-public-printer pcv)) + (pprot (eieio--class-protection pcv)) + (pinit (eieio--class-initarg-tuples pcv)) + (i 0)) + (while pa + (eieio-add-new-slot newc + (car pa) (car pd) (car pdoc) (aref ptype i) + (car pcust) (car plabel) (car pcustg) + (car printer) + (car pprot) (car-safe (car pinit)) nil nil sn) + ;; Increment each value. + (setq pa (cdr pa) + pd (cdr pd) + pdoc (cdr pdoc) + i (1+ i) + pcust (cdr pcust) + plabel (cdr plabel) + pcustg (cdr pcustg) + printer (cdr printer) + pprot (cdr pprot) + pinit (cdr pinit)) + )) ;; while/let + ;; Now duplicate all the class alloc slots. + (let ((pa (eieio--class-class-allocation-a pcv)) + (pdoc (eieio--class-class-allocation-doc pcv)) + (ptype (eieio--class-class-allocation-type pcv)) + (pcust (eieio--class-class-allocation-custom pcv)) + (plabel (eieio--class-class-allocation-custom-label pcv)) + (pcustg (eieio--class-class-allocation-custom-group pcv)) + (printer (eieio--class-class-allocation-printer pcv)) + (pprot (eieio--class-class-allocation-protection pcv)) + (pval (eieio--class-class-allocation-values pcv)) + (i 0)) + (while pa + (eieio-add-new-slot newc + (car pa) (aref pval i) (car pdoc) (aref ptype i) + (car pcust) (car plabel) (car pcustg) + (car printer) + (car pprot) nil ':class sn) + ;; Increment each value. + (setq pa (cdr pa) + pdoc (cdr pdoc) + pcust (cdr pcust) + plabel (cdr plabel) + pcustg (cdr pcustg) + printer (cdr printer) + pprot (cdr pprot) + i (1+ i)) + ))) ;; while/let + ;; Loop over each parent class + (setq ps (cdr ps))) + )) + + +;;; CLOS methods and generics +;; + +(defun eieio--defgeneric-init-form (method doc-string) + "Form to use for the initial definition of a generic." + (cond + ((or (not (fboundp method)) + (eq 'autoload (car-safe (symbol-function method)))) + ;; Make sure the method tables are installed. + (eieiomt-install method) + ;; Construct the actual body of this function. + (eieio-defgeneric-form method doc-string)) + ((generic-p method) (symbol-function method)) ;Leave it as-is. + (t (error "You cannot create a generic/method over an existing symbol: %s" + method)))) + +(defun eieio-defgeneric-form (method doc-string) + "The lambda form that would be used as the function defined on METHOD. +All methods should call the same EIEIO function for dispatch. +DOC-STRING is the documentation attached to METHOD." + `(lambda (&rest local-args) + ,doc-string + (eieio-generic-call (quote ,method) local-args))) + +(defsubst eieio-defgeneric-reset-generic-form (method) + "Setup METHOD to call the generic form." + (let ((doc-string (documentation method))) + (fset method (eieio-defgeneric-form method doc-string)))) + +(defun eieio-defgeneric-form-primary-only (method doc-string) + "The lambda form that would be used as the function defined on METHOD. +All methods should call the same EIEIO function for dispatch. +DOC-STRING is the documentation attached to METHOD." + `(lambda (&rest local-args) + ,doc-string + (eieio-generic-call-primary-only (quote ,method) local-args))) + +(defsubst eieio-defgeneric-reset-generic-form-primary-only (method) + "Setup METHOD to call the generic form." + (let ((doc-string (documentation method))) + (fset method (eieio-defgeneric-form-primary-only method doc-string)))) + +(defun eieio-defgeneric-form-primary-only-one (method doc-string + class + impl + ) + "The lambda form that would be used as the function defined on METHOD. +All methods should call the same EIEIO function for dispatch. +DOC-STRING is the documentation attached to METHOD. +CLASS is the class symbol needed for private method access. +IMPL is the symbol holding the method implementation." + ;; NOTE: I tried out byte compiling this little fcn. Turns out it + ;; is faster to execute this for not byte-compiled. ie, install this, + ;; then measure calls going through here. I wonder why. + (require 'bytecomp) + (let ((byte-compile-warnings nil)) + (byte-compile + `(lambda (&rest local-args) + ,doc-string + ;; This is a cool cheat. Usually we need to look up in the + ;; method table to find out if there is a method or not. We can + ;; instead make that determination at load time when there is + ;; only one method. If the first arg is not a child of the class + ;; of that one implementation, then clearly, there is no method def. + (if (not (eieio-object-p (car local-args))) + ;; Not an object. Just signal. + (signal 'no-method-definition + (list ',method local-args)) + + ;; We do have an object. Make sure it is the right type. + (if ,(if (eq class eieio-default-superclass) + nil ; default superclass means just an obj. Already asked. + `(not (child-of-class-p (eieio--object-class (car local-args)) + ',class))) + + ;; If not the right kind of object, call no applicable + (apply 'no-applicable-method (car local-args) + ',method local-args) + + ;; It is ok, do the call. + ;; Fill in inter-call variables then evaluate the method. + (let ((eieio-generic-call-next-method-list nil) + (eieio-generic-call-key method-primary) + (eieio-generic-call-methodname ',method) + (eieio-generic-call-arglst local-args) + ) + (eieio--with-scoped-class ',class + ,(if (< emacs-major-version 24) + `(apply ,(list 'quote impl) local-args) + `(apply #',impl local-args))) + ;(,impl local-args) + ))))))) + +(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) + "Setup METHOD to call the generic form." + (let* ((doc-string (documentation method)) + (M (get method 'eieio-method-tree)) + (entry (car (aref M method-primary))) + ) + (fset method (eieio-defgeneric-form-primary-only-one + method doc-string + (car entry) + (cdr entry) + )))) + +(defun eieio-unbind-method-implementations (method) + "Make the generic method METHOD have no implementations. +It will leave the original generic function in place, +but remove reference to all implementations of METHOD." + (put method 'eieio-method-tree nil) + (put method 'eieio-method-obarray nil)) + +(defun eieio--defmethod (method kind argclass code) + "Work part of the `defmethod' macro defining METHOD with ARGS." + (let ((key + ;; Find optional keys. + (cond ((memq kind '(:BEFORE :before)) method-before) + ((memq kind '(:AFTER :after)) method-after) + ((memq kind '(:STATIC :static)) method-static) + ((memq kind '(:PRIMARY :primary nil)) method-primary) + ;; Primary key. + ;; (t method-primary) + (t (error "Unknown method kind %S" kind))))) + ;; Make sure there is a generic (when called from defclass). + (eieio--defalias + method (eieio--defgeneric-init-form + method (or (documentation code) + (format "Generically created method `%s'." method)))) + ;; Create symbol for property to bind to. If the first arg is of + ;; the form (varname vartype) and `vartype' is a class, then + ;; that class will be the type symbol. If not, then it will fall + ;; under the type `primary' which is a non-specific calling of the + ;; function. + (if argclass + (if (not (class-p argclass)) + (error "Unknown class type %s in method parameters" + argclass)) + ;; Generics are higher. + (setq key (eieio-specialized-key-to-generic-key key))) + ;; Put this lambda into the symbol so we can find it. + (eieiomt-add method code key argclass) + ) + + (when eieio-optimize-primary-methods-flag + ;; Optimizing step: + ;; + ;; If this method, after this setup, only has primary methods, then + ;; we can setup the generic that way. + (if (generic-primary-only-p method) + ;; If there is only one primary method, then we can go one more + ;; optimization step. + (if (generic-primary-only-one-p method) + (eieio-defgeneric-reset-generic-form-primary-only-one method) + (eieio-defgeneric-reset-generic-form-primary-only method)) + (eieio-defgeneric-reset-generic-form method))) + + method) + +;;; Slot type validation + +;; This is a hideous hack for replacing `typep' from cl-macs, to avoid +;; requiring the CL library at run-time. It can be eliminated if/when +;; `typep' is merged into Emacs core. +(defun eieio--typep (val type) + (if (symbolp type) + (cond ((get type 'cl-deftype-handler) + (eieio--typep val (funcall (get type 'cl-deftype-handler)))) + ((eq type t) t) + ((eq type 'null) (null val)) + ((eq type 'atom) (atom val)) + ((eq type 'float) (and (numberp val) (not (integerp val)))) + ((eq type 'real) (numberp val)) + ((eq type 'fixnum) (integerp val)) + ((memq type '(character string-char)) (characterp val)) + (t + (let* ((name (symbol-name type)) + (namep (intern (concat name "p")))) + (if (fboundp namep) + (funcall `(lambda () (,namep val))) + (funcall `(lambda () + (,(intern (concat name "-p")) val))))))) + (cond ((get (car type) 'cl-deftype-handler) + (eieio--typep val (apply (get (car type) 'cl-deftype-handler) + (cdr type)))) + ((memq (car type) '(integer float real number)) + (and (eieio--typep val (car type)) + (or (memq (cadr type) '(* nil)) + (if (consp (cadr type)) + (> val (car (cadr type))) + (>= val (cadr type)))) + (or (memq (caddr type) '(* nil)) + (if (consp (car (cddr type))) + (< val (caar (cddr type))) + (<= val (car (cddr type))))))) + ((memq (car type) '(and or not)) + (eval (cons (car type) + (mapcar (lambda (x) + `(eieio--typep (quote ,val) (quote ,x))) + (cdr type))))) + ((memq (car type) '(member member*)) + (memql val (cdr type))) + ((eq (car type) 'satisfies) + (funcall `(lambda () (,(cadr type) val)))) + (t (error "Bad type spec: %s" type))))) + +(defun eieio-perform-slot-validation (spec value) + "Return non-nil if SPEC does not match VALUE." + (or (eq spec t) ; t always passes + (eq value eieio-unbound) ; unbound always passes + (eieio--typep value spec))) + +(defun eieio-validate-slot-value (class slot-idx value slot) + "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. +Checks the :type specifier. +SLOT is the slot that is being checked, and is only used when throwing +an error." + (if eieio-skip-typecheck + nil + ;; Trim off object IDX junk added in for the object index. + (setq slot-idx (- slot-idx 3)) + (let ((st (aref (eieio--class-public-type (class-v class)) slot-idx))) + (if (not (eieio-perform-slot-validation st value)) + (signal 'invalid-slot-type (list class slot st value)))))) + +(defun eieio-validate-class-slot-value (class slot-idx value slot) + "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. +Checks the :type specifier. +SLOT is the slot that is being checked, and is only used when throwing +an error." + (if eieio-skip-typecheck + nil + (let ((st (aref (eieio--class-class-allocation-type (class-v class)) + slot-idx))) + (if (not (eieio-perform-slot-validation st value)) + (signal 'invalid-slot-type (list class slot st value)))))) + +(defun eieio-barf-if-slot-unbound (value instance slotname fn) + "Throw a signal if VALUE is a representation of an UNBOUND slot. +INSTANCE is the object being referenced. SLOTNAME is the offending +slot. If the slot is ok, return VALUE. +Argument FN is the function calling this verifier." + (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) + (slot-unbound instance (eieio--object-class instance) slotname fn) + value)) + + +;;; Get/Set slots in an object. +;; +(defun eieio-oref (obj slot) + "Return the value in OBJ at SLOT in the object vector." + (eieio--check-type (or eieio-object-p class-p) obj) + (eieio--check-type symbolp slot) + (if (class-p obj) (eieio-class-un-autoload obj)) + (let* ((class (if (class-p obj) obj (eieio--object-class obj))) + (c (eieio-slot-name-index class obj slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c (eieio-class-slot-name-index class slot)) + ;; Oref that slot. + (aref (eieio--class-class-allocation-values (class-v class)) c) + ;; The slot-missing method is a cool way of allowing an object author + ;; to intercept missing slot definitions. Since it is also the LAST + ;; thing called in this fn, its return value would be retrieved. + (slot-missing obj slot 'oref) + ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) + ) + (eieio--check-type eieio-object-p obj) + (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + + +(defun eieio-oref-default (obj slot) + "Do the work for the macro `oref-default' with similar parameters. +Fills in OBJ's SLOT with its default value." + (eieio--check-type (or eieio-object-p class-p) obj) + (eieio--check-type symbolp slot) + (let* ((cl (if (eieio-object-p obj) (eieio--object-class obj) obj)) + (c (eieio-slot-name-index cl obj slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c + (eieio-class-slot-name-index cl slot)) + ;; Oref that slot. + (aref (eieio--class-class-allocation-values (class-v cl)) + c) + (slot-missing obj slot 'oref-default) + ;;(signal 'invalid-slot-name (list (class-name cl) slot)) + ) + (eieio-barf-if-slot-unbound + (let ((val (nth (- c 3) (eieio--class-public-d (class-v cl))))) + (eieio-default-eval-maybe val)) + obj cl 'oref-default)))) + +(defun eieio-default-eval-maybe (val) + "Check VAL, and return what `oref-default' would provide." + (cond + ;; Is it a function call? If so, evaluate it. + ((eieio-eval-default-p val) + (eval val)) + ;;;; check for quoted things, and unquote them + ;;((and (consp val) (eq (car val) 'quote)) + ;; (car (cdr val))) + ;; return it verbatim + (t val))) + +(defun eieio-oset (obj slot value) + "Do the work for the macro `oset'. +Fills in OBJ's SLOT with VALUE." + (eieio--check-type eieio-object-p obj) + (eieio--check-type symbolp slot) + (let ((c (eieio-slot-name-index (eieio--object-class obj) obj slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c + (eieio-class-slot-name-index (eieio--object-class obj) slot)) + ;; Oset that slot. + (progn + (eieio-validate-class-slot-value (eieio--object-class obj) c value slot) + (aset (eieio--class-class-allocation-values (class-v (eieio--object-class obj))) + c value)) + ;; See oref for comment on `slot-missing' + (slot-missing obj slot 'oset value) + ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) + ) + (eieio-validate-slot-value (eieio--object-class obj) c value slot) + (aset obj c value)))) + +(defun eieio-oset-default (class slot value) + "Do the work for the macro `oset-default'. +Fills in the default value in CLASS' in SLOT with VALUE." + (eieio--check-type class-p class) + (eieio--check-type symbolp slot) + (eieio--with-scoped-class class + (let* ((c (eieio-slot-name-index class nil slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c (eieio-class-slot-name-index class slot)) + (progn + ;; Oref that slot. + (eieio-validate-class-slot-value class c value slot) + (aset (eieio--class-class-allocation-values (class-v class)) c + value)) + (signal 'invalid-slot-name (list (eieio-class-name class) slot))) + (eieio-validate-slot-value class c value slot) + ;; Set this into the storage for defaults. + (setcar (nthcdr (- c 3) (eieio--class-public-d (class-v class))) + value) + ;; Take the value, and put it into our cache object. + (eieio-oset (eieio--class-default-object-cache (class-v class)) + slot value) + )))) + + +;;; EIEIO internal search functions +;; +(defun eieio-slot-originating-class-p (start-class slot) + "Return non-nil if START-CLASS is the first class to define SLOT. +This is for testing if the class currently in scope is the class that defines SLOT +so that we can protect private slots." + (let ((par (eieio-class-parents-fast start-class)) + (ret t)) + (if (not par) + t + (while (and par ret) + (if (intern-soft (symbol-name slot) + (eieio--class-symbol-obarray (class-v (car par)))) + (setq ret nil)) + (setq par (cdr par))) + ret))) + +(defun eieio-slot-name-index (class obj slot) + "In CLASS for OBJ find the index of the named SLOT. +The slot is a symbol which is installed in CLASS by the `defclass' +call. OBJ can be nil, but if it is an object, and the slot in question +is protected, access will be allowed if OBJ is a child of the currently +scoped class. +If SLOT is the value created with :initarg instead, +reverse-lookup that name, and recurse with the associated slot value." + ;; Removed checks to outside this call + (let* ((fsym (intern-soft (symbol-name slot) + (eieio--class-symbol-obarray (class-v class)))) + (fsi (if (symbolp fsym) (symbol-value fsym) nil))) + (if (integerp fsi) + (cond + ((not (get fsym 'protection)) + (+ 3 fsi)) + ((and (eq (get fsym 'protection) 'protected) + (eieio--scoped-class) + (or (child-of-class-p class (eieio--scoped-class)) + (and (eieio-object-p obj) + (child-of-class-p class (eieio--object-class obj))))) + (+ 3 fsi)) + ((and (eq (get fsym 'protection) 'private) + (or (and (eieio--scoped-class) + (eieio-slot-originating-class-p (eieio--scoped-class) slot)) + eieio-initializing-object)) + (+ 3 fsi)) + (t nil)) + (let ((fn (eieio-initarg-to-attribute class slot))) + (if fn (eieio-slot-name-index class obj fn) nil))))) + +(defun eieio-class-slot-name-index (class slot) + "In CLASS find the index of the named SLOT. +The slot is a symbol which is installed in CLASS by the `defclass' +call. If SLOT is the value created with :initarg instead, +reverse-lookup that name, and recurse with the associated slot value." + ;; This will happen less often, and with fewer slots. Do this the + ;; storage cheap way. + (let* ((a (eieio--class-class-allocation-a (class-v class))) + (l1 (length a)) + (af (memq slot a)) + (l2 (length af))) + ;; Slot # is length of the total list, minus the remaining list of + ;; the found slot. + (if af (- l1 l2)))) + +;;; +;; Way to assign slots based on a list. Used for constructors, or +;; even resetting an object at run-time +;; +(defun eieio-set-defaults (obj &optional set-all) + "Take object OBJ, and reset all slots to their defaults. +If SET-ALL is non-nil, then when a default is nil, that value is +reset. If SET-ALL is nil, the slots are only reset if the default is +not nil." + (eieio--with-scoped-class (eieio--object-class obj) + (let ((eieio-initializing-object t) + (pub (eieio--class-public-a (class-v (eieio--object-class obj))))) + (while pub + (let ((df (eieio-oref-default obj (car pub)))) + (if (or df set-all) + (eieio-oset obj (car pub) df))) + (setq pub (cdr pub)))))) + +(defun eieio-initarg-to-attribute (class initarg) + "For CLASS, convert INITARG to the actual attribute name. +If there is no translation, pass it in directly (so we can cheat if +need be... May remove that later...)" + (let ((tuple (assoc initarg (eieio--class-initarg-tuples (class-v class))))) + (if tuple + (cdr tuple) + nil))) + +(defun eieio-attribute-to-initarg (class attribute) + "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. +This is usually a symbol that starts with `:'." + (let ((tuple (rassoc attribute (eieio--class-initarg-tuples (class-v class))))) + (if tuple + (car tuple) + nil))) + +;;; +;; Method Invocation order: C3 +(defun eieio-c3-candidate (class remaining-inputs) + "Return CLASS if it can go in the result now, otherwise nil" + ;; Ensure CLASS is not in any position but the first in any of the + ;; element lists of REMAINING-INPUTS. + (and (not (let ((found nil)) + (while (and remaining-inputs (not found)) + (setq found (member class (cdr (car remaining-inputs))) + remaining-inputs (cdr remaining-inputs))) + found)) + class)) + +(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) + "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. +If a consistent order does not exist, signal an error." + (if (let ((tail remaining-inputs) + (found nil)) + (while (and tail (not found)) + (setq found (car tail) tail (cdr tail))) + (not found)) + ;; If all remaining inputs are empty lists, we are done. + (nreverse reversed-partial-result) + ;; Otherwise, we try to find the next element of the result. This + ;; is achieved by considering the first element of each + ;; (non-empty) input list and accepting a candidate if it is + ;; consistent with the rests of the input lists. + (let* ((found nil) + (tail remaining-inputs) + (next (progn + (while (and tail (not found)) + (setq found (and (car tail) + (eieio-c3-candidate (caar tail) + remaining-inputs)) + tail (cdr tail))) + found))) + (if next + ;; The graph is consistent so far, add NEXT to result and + ;; merge input lists, dropping NEXT from their heads where + ;; applicable. + (eieio-c3-merge-lists + (cons next reversed-partial-result) + (mapcar (lambda (l) (if (eq (first l) next) (rest l) l)) + remaining-inputs)) + ;; The graph is inconsistent, give up + (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) + +(defun eieio-class-precedence-c3 (class) + "Return all parents of CLASS in c3 order." + (let ((parents (eieio-class-parents-fast class))) + (eieio-c3-merge-lists + (list class) + (append + (or + (mapcar + (lambda (x) + (eieio-class-precedence-c3 x)) + parents) + '((eieio-default-superclass))) + (list parents)))) + ) +;;; +;; Method Invocation Order: Depth First + +(defun eieio-class-precedence-dfs (class) + "Return all parents of CLASS in depth-first order." + (let* ((parents (eieio-class-parents-fast class)) + (classes (copy-sequence + (apply #'append + (list class) + (or + (mapcar + (lambda (parent) + (cons parent + (eieio-class-precedence-dfs parent))) + parents) + '((eieio-default-superclass)))))) + (tail classes)) + ;; Remove duplicates. + (while tail + (setcdr tail (delq (car tail) (cdr tail))) + (setq tail (cdr tail))) + classes)) + +;;; +;; Method Invocation Order: Breadth First +(defun eieio-class-precedence-bfs (class) + "Return all parents of CLASS in breadth-first order." + (let ((result) + (queue (or (eieio-class-parents-fast class) + '(eieio-default-superclass)))) + (while queue + (let ((head (pop queue))) + (unless (member head result) + (push head result) + (unless (eq head 'eieio-default-superclass) + (setq queue (append queue (or (eieio-class-parents-fast head) + '(eieio-default-superclass)))))))) + (cons class (nreverse result))) + ) + +;;; +;; Method Invocation Order + +(defun eieio-class-precedence-list (class) + "Return (transitively closed) list of parents of CLASS. +The order, in which the parents are returned depends on the +method invocation orders of the involved classes." + (if (or (null class) (eq class 'eieio-default-superclass)) + nil + (case (class-method-invocation-order class) + (:depth-first + (eieio-class-precedence-dfs class)) + (:breadth-first + (eieio-class-precedence-bfs class)) + (:c3 + (eieio-class-precedence-c3 class)))) + ) +(define-obsolete-function-alias + 'class-precedence-list 'eieio-class-precedence-list "24.4") + + +;;; CLOS generics internal function handling +;; +(defvar eieio-generic-call-methodname nil + "When using `call-next-method', provides a context on how to do it.") +(defvar eieio-generic-call-arglst nil + "When using `call-next-method', provides a context for parameters.") +(defvar eieio-generic-call-key nil + "When using `call-next-method', provides a context for the current key. +Keys are a number representing :before, :primary, and :after methods.") +(defvar eieio-generic-call-next-method-list nil + "When executing a PRIMARY or STATIC method, track the 'next-method'. +During executions, the list is first generated, then as each next method +is called, the next method is popped off the stack.") + +(define-obsolete-variable-alias 'eieio-pre-method-execution-hooks + 'eieio-pre-method-execution-functions "24.3") +(defvar eieio-pre-method-execution-functions nil + "Abnormal hook run just before an EIEIO method is executed. +The hook function must accept one argument, the list of forms +about to be executed.") + +(defun eieio-generic-call (method args) + "Call METHOD with ARGS. +ARGS provides the context on which implementation to use. +This should only be called from a generic function." + ;; We must expand our arguments first as they are always + ;; passed in as quoted symbols + (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) + (eieio-generic-call-methodname method) + (eieio-generic-call-arglst args) + (firstarg nil) + (primarymethodlist nil)) + ;; get a copy + (setq newargs args + firstarg (car newargs)) + ;; Is the class passed in autoloaded? + ;; Since class names are also constructors, they can be autoloaded + ;; via the autoload command. Check for this, and load them in. + ;; It is ok if it doesn't turn out to be a class. Probably want that + ;; function loaded anyway. + (if (and (symbolp firstarg) + (fboundp firstarg) + (listp (symbol-function firstarg)) + (eq 'autoload (car (symbol-function firstarg)))) + (load (nth 1 (symbol-function firstarg)))) + ;; Determine the class to use. + (cond ((eieio-object-p firstarg) + (setq mclass (eieio--object-class firstarg))) + ((class-p firstarg) + (setq mclass firstarg)) + ) + ;; Make sure the class is a valid class + ;; mclass can be nil (meaning a generic for should be used. + ;; mclass cannot have a value that is not a class, however. + (when (and (not (null mclass)) (not (class-p mclass))) + (error "Cannot dispatch method %S on class %S" + method mclass) + ) + ;; Now create a list in reverse order of all the calls we have + ;; make in order to successfully do this right. Rules: + ;; 1) Only call generics if scoped-class is not defined + ;; This prevents multiple calls in the case of recursion + ;; 2) Only call static if this is a static method. + ;; 3) Only call specifics if the definition allows for them. + ;; 4) Call in order based on :before, :primary, and :after + (when (eieio-object-p firstarg) + ;; Non-static calls do all this stuff. + + ;; :after methods + (setq tlambdas + (if mclass + (eieiomt-method-list method method-after mclass) + (list (eieio-generic-form method method-after nil))) + ;;(or (and mclass (eieio-generic-form method method-after mclass)) + ;; (eieio-generic-form method method-after nil)) + ) + (setq lambdas (append tlambdas lambdas) + keys (append (make-list (length tlambdas) method-after) keys)) + + ;; :primary methods + (setq tlambdas + (or (and mclass (eieio-generic-form method method-primary mclass)) + (eieio-generic-form method method-primary nil))) + (when tlambdas + (setq lambdas (cons tlambdas lambdas) + keys (cons method-primary keys) + primarymethodlist + (eieiomt-method-list method method-primary mclass))) + + ;; :before methods + (setq tlambdas + (if mclass + (eieiomt-method-list method method-before mclass) + (list (eieio-generic-form method method-before nil))) + ;;(or (and mclass (eieio-generic-form method method-before mclass)) + ;; (eieio-generic-form method method-before nil)) + ) + (setq lambdas (append tlambdas lambdas) + keys (append (make-list (length tlambdas) method-before) keys)) + ) + + (if mclass + ;; For the case of a class, + ;; if there were no methods found, then there could be :static methods. + (when (not lambdas) + (setq tlambdas + (eieio-generic-form method method-static mclass)) + (setq lambdas (cons tlambdas lambdas) + keys (cons method-static keys) + primarymethodlist ;; Re-use even with bad name here + (eieiomt-method-list method method-static mclass))) + ;; For the case of no class (ie - mclass == nil) then there may + ;; be a primary method. + (setq tlambdas + (eieio-generic-form method method-primary nil)) + (when tlambdas + (setq lambdas (cons tlambdas lambdas) + keys (cons method-primary keys) + primarymethodlist + (eieiomt-method-list method method-primary nil))) + ) + + (run-hook-with-args 'eieio-pre-method-execution-functions + primarymethodlist) + + ;; Now loop through all occurrences forms which we must execute + ;; (which are happily sorted now) and execute them all! + (let ((rval nil) (lastval nil) (rvalever nil) (found nil)) + (while lambdas + (if (car lambdas) + (eieio--with-scoped-class (cdr (car lambdas)) + (let* ((eieio-generic-call-key (car keys)) + (has-return-val + (or (= eieio-generic-call-key method-primary) + (= eieio-generic-call-key method-static))) + (eieio-generic-call-next-method-list + ;; Use the cdr, as the first element is the fcn + ;; we are calling right now. + (when has-return-val (cdr primarymethodlist))) + ) + (setq found t) + ;;(setq rval (apply (car (car lambdas)) newargs)) + (setq lastval (apply (car (car lambdas)) newargs)) + (when has-return-val + (setq rval lastval + rvalever t)) + ))) + (setq lambdas (cdr lambdas) + keys (cdr keys))) + (if (not found) + (if (eieio-object-p (car args)) + (setq rval (apply 'no-applicable-method (car args) method args) + rvalever t) + (signal + 'no-method-definition + (list method args)))) + ;; Right Here... it could be that lastval is returned when + ;; rvalever is nil. Is that right? + rval))) + +(defun eieio-generic-call-primary-only (method args) + "Call METHOD with ARGS for methods with only :PRIMARY implementations. +ARGS provides the context on which implementation to use. +This should only be called from a generic function. + +This method is like `eieio-generic-call', but only +implementations in the :PRIMARY slot are queried. After many +years of use, it appears that over 90% of methods in use +have :PRIMARY implementations only. We can therefore optimize +for this common case to improve performance." + ;; We must expand our arguments first as they are always + ;; passed in as quoted symbols + (let ((newargs nil) (mclass nil) (lambdas nil) + (eieio-generic-call-methodname method) + (eieio-generic-call-arglst args) + (firstarg nil) + (primarymethodlist nil) + ) + ;; get a copy + (setq newargs args + firstarg (car newargs)) + + ;; Determine the class to use. + (cond ((eieio-object-p firstarg) + (setq mclass (eieio--object-class firstarg))) + ((not firstarg) + (error "Method %s called on nil" method)) + ((not (eieio-object-p firstarg)) + (error "Primary-only method %s called on something not an object" method)) + (t + (error "EIEIO Error: Improperly classified method %s as primary only" + method) + )) + ;; Make sure the class is a valid class + ;; mclass can be nil (meaning a generic for should be used. + ;; mclass cannot have a value that is not a class, however. + (when (null mclass) + (error "Cannot dispatch method %S on class %S" method mclass) + ) + + ;; :primary methods + (setq lambdas (eieio-generic-form method method-primary mclass)) + (setq primarymethodlist ;; Re-use even with bad name here + (eieiomt-method-list method method-primary mclass)) + + ;; Now loop through all occurrences forms which we must execute + ;; (which are happily sorted now) and execute them all! + (eieio--with-scoped-class (cdr lambdas) + (let* ((rval nil) (lastval nil) (rvalever nil) + (eieio-generic-call-key method-primary) + ;; Use the cdr, as the first element is the fcn + ;; we are calling right now. + (eieio-generic-call-next-method-list (cdr primarymethodlist)) + ) + + (if (or (not lambdas) (not (car lambdas))) + + ;; No methods found for this impl... + (if (eieio-object-p (car args)) + (setq rval (apply 'no-applicable-method (car args) method args) + rvalever t) + (signal + 'no-method-definition + (list method args))) + + ;; Do the regular implementation here. + + (run-hook-with-args 'eieio-pre-method-execution-functions + lambdas) + + (setq lastval (apply (car lambdas) newargs)) + (setq rval lastval + rvalever t) + ) + + ;; Right Here... it could be that lastval is returned when + ;; rvalever is nil. Is that right? + rval)))) + +(defun eieiomt-method-list (method key class) + "Return an alist list of methods lambdas. +METHOD is the method name. +KEY represents either :before, or :after methods. +CLASS is the starting class to search from in the method tree. +If CLASS is nil, then an empty list of methods should be returned." + ;; Note: eieiomt - the MT means MethodTree. See more comments below + ;; for the rest of the eieiomt methods. + + ;; Collect lambda expressions stored for the class and its parent + ;; classes. + (let (lambdas) + (dolist (ancestor (eieio-class-precedence-list class)) + ;; Lookup the form to use for the PRIMARY object for the next level + (let ((tmpl (eieio-generic-form method key ancestor))) + (when (and tmpl + (or (not lambdas) + ;; This prevents duplicates coming out of the + ;; class method optimizer. Perhaps we should + ;; just not optimize before/afters? + (not (member tmpl lambdas)))) + (push tmpl lambdas)))) + + ;; Return collected lambda. For :after methods, return in current + ;; order (most general class last); Otherwise, reverse order. + (if (eq key method-after) + lambdas + (nreverse lambdas)))) + + +;;; +;; eieio-method-tree : eieiomt- +;; +;; Stored as eieio-method-tree in property list of a generic method +;; +;; (eieio-method-tree . [BEFORE PRIMARY AFTER +;; genericBEFORE genericPRIMARY genericAFTER]) +;; and +;; (eieio-method-obarray . [BEFORE PRIMARY AFTER +;; genericBEFORE genericPRIMARY genericAFTER]) +;; where the association is a vector. +;; (aref 0 -- all static methods. +;; (aref 1 -- all methods classified as :before +;; (aref 2 -- all methods classified as :primary +;; (aref 3 -- all methods classified as :after +;; (aref 4 -- a generic classified as :before +;; (aref 5 -- a generic classified as :primary +;; (aref 6 -- a generic classified as :after +;; +(defvar eieiomt-optimizing-obarray nil + "While mapping atoms, this contain the obarray being optimized.") + +(defun eieiomt-install (method-name) + "Install the method tree, and obarray onto METHOD-NAME. +Do not do the work if they already exist." + (let ((emtv (get method-name 'eieio-method-tree)) + (emto (get method-name 'eieio-method-obarray))) + (if (or (not emtv) (not emto)) + (progn + (setq emtv (put method-name 'eieio-method-tree + (make-vector method-num-slots nil)) + emto (put method-name 'eieio-method-obarray + (make-vector method-num-slots nil))) + (aset emto 0 (make-vector 11 0)) + (aset emto 1 (make-vector 11 0)) + (aset emto 2 (make-vector 41 0)) + (aset emto 3 (make-vector 11 0)) + )))) + +(defun eieiomt-add (method-name method key class) + "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. +METHOD-NAME is the name created by a call to `defgeneric'. +METHOD are the forms for a given implementation. +KEY is an integer (see comment in eieio.el near this function) which +is associated with the :static :before :primary and :after tags. +It also indicates if CLASS is defined or not. +CLASS is the class this method is associated with." + (if (or (> key method-num-slots) (< key 0)) + (error "eieiomt-add: method key error!")) + (let ((emtv (get method-name 'eieio-method-tree)) + (emto (get method-name 'eieio-method-obarray))) + ;; Make sure the method tables are available. + (if (or (not emtv) (not emto)) + (error "Programmer error: eieiomt-add")) + ;; only add new cells on if it doesn't already exist! + (if (assq class (aref emtv key)) + (setcdr (assq class (aref emtv key)) method) + (aset emtv key (cons (cons class method) (aref emtv key)))) + ;; Add function definition into newly created symbol, and store + ;; said symbol in the correct obarray, otherwise use the + ;; other array to keep this stuff + (if (< key method-num-lists) + (let ((nsym (intern (symbol-name class) (aref emto key)))) + (fset nsym method))) + ;; Save the defmethod file location in a symbol property. + (let ((fname (if load-in-progress + load-file-name + buffer-file-name)) + loc) + (when fname + (when (string-match "\\.elc$" fname) + (setq fname (substring fname 0 (1- (length fname))))) + (setq loc (get method-name 'method-locations)) + (pushnew (list class fname) loc :test 'equal) + (put method-name 'method-locations loc))) + ;; Now optimize the entire obarray + (if (< key method-num-lists) + (let ((eieiomt-optimizing-obarray (aref emto key))) + ;; @todo - Is this overkill? Should we just clear the symbol? + (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray))) + )) + +(defun eieiomt-next (class) + "Return the next parent class for CLASS. +If CLASS is a superclass, return variable `eieio-default-superclass'. +If CLASS is variable `eieio-default-superclass' then return nil. +This is different from function `class-parent' as class parent returns +nil for superclasses. This function performs no type checking!" + ;; No type-checking because all calls are made from functions which + ;; are safe and do checking for us. + (or (eieio-class-parents-fast class) + (if (eq class 'eieio-default-superclass) + nil + '(eieio-default-superclass)))) + +(defun eieiomt-sym-optimize (s) + "Find the next class above S which has a function body for the optimizer." + ;; Set the value to nil in case there is no nearest cell. + (set s nil) + ;; Find the nearest cell that has a function body. If we find one, + ;; we replace the nil from above. + (let ((external-symbol (intern-soft (symbol-name s)))) + (catch 'done + (dolist (ancestor (rest (eieio-class-precedence-list external-symbol))) + (let ((ov (intern-soft (symbol-name ancestor) + eieiomt-optimizing-obarray))) + (when (fboundp ov) + (set s ov) ;; store ov as our next symbol + (throw 'done ancestor))))))) + +(defun eieio-generic-form (method key class) + "Return the lambda form belonging to METHOD using KEY based upon CLASS. +If CLASS is not a class then use `generic' instead. If class has +no form, but has a parent class, then trace to that parent class. +The first time a form is requested from a symbol, an optimized path +is memorized for faster future use." + (let ((emto (aref (get method 'eieio-method-obarray) + (if class key (eieio-specialized-key-to-generic-key key))))) + (if (class-p class) + ;; 1) find our symbol + (let ((cs (intern-soft (symbol-name class) emto))) + (if (not cs) + ;; 2) If there isn't one, then make one. + ;; This can be slow since it only occurs once + (progn + (setq cs (intern (symbol-name class) emto)) + ;; 2.1) Cache its nearest neighbor with a quick optimize + ;; which should only occur once for this call ever + (let ((eieiomt-optimizing-obarray emto)) + (eieiomt-sym-optimize cs)))) + ;; 3) If it's bound return this one. + (if (fboundp cs) + (cons cs (eieio--class-symbol (class-v class))) + ;; 4) If it's not bound then this variable knows something + (if (symbol-value cs) + (progn + ;; 4.1) This symbol holds the next class in its value + (setq class (symbol-value cs) + cs (intern-soft (symbol-name class) emto)) + ;; 4.2) The optimizer should always have chosen a + ;; function-symbol + ;;(if (fboundp cs) + (cons cs (eieio--class-symbol (class-v (intern (symbol-name class))))) + ;;(error "EIEIO optimizer: erratic data loss!")) + ) + ;; There never will be a funcall... + nil))) + ;; for a generic call, what is a list, is the function body we want. + (let ((emtl (aref (get method 'eieio-method-tree) + (if class key (eieio-specialized-key-to-generic-key key))))) + (if emtl + ;; The car of EMTL is supposed to be a class, which in this + ;; case is nil, so skip it. + (cons (cdr (car emtl)) nil) + nil))))) + + +;;; Here are some special types of errors +;; +(intern "no-method-definition") +(put 'no-method-definition 'error-conditions '(no-method-definition error)) +(put 'no-method-definition 'error-message "No method definition") + +(intern "no-next-method") +(put 'no-next-method 'error-conditions '(no-next-method error)) +(put 'no-next-method 'error-message "No next method") + +(intern "invalid-slot-name") +(put 'invalid-slot-name 'error-conditions '(invalid-slot-name error)) +(put 'invalid-slot-name 'error-message "Invalid slot name") + +(intern "invalid-slot-type") +(put 'invalid-slot-type 'error-conditions '(invalid-slot-type error nil)) +(put 'invalid-slot-type 'error-message "Invalid slot type") + +(intern "unbound-slot") +(put 'unbound-slot 'error-conditions '(unbound-slot error nil)) +(put 'unbound-slot 'error-message "Unbound slot") + +(intern "inconsistent-class-hierarchy") +(put 'inconsistent-class-hierarchy 'error-conditions + '(inconsistent-class-hierarchy error nil)) +(put 'inconsistent-class-hierarchy 'error-message "Inconsistent class hierarchy") + +;;; Obsolete backward compatibility functions. +;; Needed to run byte-code compiled with the EIEIO of Emacs-23. + +(defun eieio-defmethod (method args) + "Obsolete work part of an old version of the `defmethod' macro." + (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) + ;; find optional keys + (setq key + (cond ((memq (car args) '(:BEFORE :before)) + (setq args (cdr args)) + method-before) + ((memq (car args) '(:AFTER :after)) + (setq args (cdr args)) + method-after) + ((memq (car args) '(:STATIC :static)) + (setq args (cdr args)) + method-static) + ((memq (car args) '(:PRIMARY :primary)) + (setq args (cdr args)) + method-primary) + ;; Primary key. + (t method-primary))) + ;; Get body, and fix contents of args to be the arguments of the fn. + (setq body (cdr args) + args (car args)) + (setq loopa args) + ;; Create a fixed version of the arguments. + (while loopa + (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) + argfix)) + (setq loopa (cdr loopa))) + ;; Make sure there is a generic. + (eieio-defgeneric + method + (if (stringp (car body)) + (car body) (format "Generically created method `%s'." method))) + ;; create symbol for property to bind to. If the first arg is of + ;; the form (varname vartype) and `vartype' is a class, then + ;; that class will be the type symbol. If not, then it will fall + ;; under the type `primary' which is a non-specific calling of the + ;; function. + (setq firstarg (car args)) + (if (listp firstarg) + (progn + (setq argclass (nth 1 firstarg)) + (if (not (class-p argclass)) + (error "Unknown class type %s in method parameters" + (nth 1 firstarg)))) + ;; Generics are higher. + (setq key (eieio-specialized-key-to-generic-key key))) + ;; Put this lambda into the symbol so we can find it. + (if (byte-code-function-p (car-safe body)) + (eieiomt-add method (car-safe body) key argclass) + (eieiomt-add method (append (list 'lambda (reverse argfix)) body) + key argclass)) + ) + + (when eieio-optimize-primary-methods-flag + ;; Optimizing step: + ;; + ;; If this method, after this setup, only has primary methods, then + ;; we can setup the generic that way. + (if (generic-primary-only-p method) + ;; If there is only one primary method, then we can go one more + ;; optimization step. + (if (generic-primary-only-one-p method) + (eieio-defgeneric-reset-generic-form-primary-only-one method) + (eieio-defgeneric-reset-generic-form-primary-only method)) + (eieio-defgeneric-reset-generic-form method))) + + method) +(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1") + +(defun eieio-defgeneric (method doc-string) + "Obsolete work part of an old version of the `defgeneric' macro." + (if (and (fboundp method) (not (generic-p method)) + (or (byte-code-function-p (symbol-function method)) + (not (eq 'autoload (car (symbol-function method))))) + ) + (error "You cannot create a generic/method over an existing symbol: %s" + method)) + ;; Don't do this over and over. + (unless (fboundp 'method) + ;; This defun tells emacs where the first definition of this + ;; method is defined. + `(defun ,method nil) + ;; Make sure the method tables are installed. + (eieiomt-install method) + ;; Apply the actual body of this function. + (fset method (eieio-defgeneric-form method doc-string)) + ;; Return the method + 'method)) +(make-obsolete 'eieio-defgeneric nil "24.1") + +(provide 'eieio-core) + +;;; eieio-core.el ends here diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index f9917bddd42..cbb35fee3f6 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -1,10 +1,11 @@ ;;; eieio-custom.el -- eieio object customization -;; Copyright (C) 1999-2001, 2005, 2007-2013 Free Software Foundation, +;; Copyright (C) 1999-2001, 2005, 2007-2014 Free Software Foundation, ;; Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 +;; Old-Version: 0.2 (using "Version:" made Emacs think this is package +;; eieio-0.2). ;; Keywords: OO, lisp ;; Package: eieio @@ -472,4 +473,8 @@ Return the symbol for the group, or nil" (provide 'eieio-custom) +;; Local variables: +;; generated-autoload-file: "eieio.el" +;; End: + ;;; eieio-custom.el ends here diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 7daa24257a1..ae29c3fbe90 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -1,6 +1,6 @@ ;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2014 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp @@ -80,38 +80,39 @@ PREBUTTONTEXT is some text between PREFIX and the object button." ;; Each object should have an opportunity to show stuff about itself. (defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) - prefix) + prefix) "Insert the slots of OBJ into the current DDEBUG buffer." - (data-debug-insert-thing (eieio-object-name-string obj) - prefix - "Name: ") - (let* ((cl (eieio-object-class obj)) - (cv (class-v cl))) - (data-debug-insert-thing (class-constructor cl) - prefix - "Class: ") - ;; Loop over all the public slots - (let ((publa (eieio--class-public-a cv)) - ) - (while publa - (if (slot-boundp obj (car publa)) - (let* ((i (class-slot-initarg cl (car publa))) - (v (eieio-oref obj (car publa)))) - (data-debug-insert-thing - v prefix (concat - (if i (symbol-name i) - (symbol-name (car publa))) - " "))) - ;; Unbound case - (let ((i (class-slot-initarg cl (car publa)))) - (data-debug-insert-custom - "#unbound" prefix - (concat (if i (symbol-name i) - (symbol-name (car publa))) - " ") - 'font-lock-keyword-face)) - ) - (setq publa (cdr publa)))))) + (let ((inhibit-read-only t)) + (data-debug-insert-thing (eieio-object-name-string obj) + prefix + "Name: ") + (let* ((cl (eieio-object-class obj)) + (cv (class-v cl))) + (data-debug-insert-thing (class-constructor cl) + prefix + "Class: ") + ;; Loop over all the public slots + (let ((publa (eieio--class-public-a cv)) + ) + (while publa + (if (slot-boundp obj (car publa)) + (let* ((i (class-slot-initarg cl (car publa))) + (v (eieio-oref obj (car publa)))) + (data-debug-insert-thing + v prefix (concat + (if i (symbol-name i) + (symbol-name (car publa))) + " "))) + ;; Unbound case + (let ((i (class-slot-initarg cl (car publa)))) + (data-debug-insert-custom + "#unbound" prefix + (concat (if i (symbol-name i) + (symbol-name (car publa))) + " ") + 'font-lock-keyword-face)) + ) + (setq publa (cdr publa))))))) ;;; Augment the Data debug thing display list. (data-debug-add-specialized-thing (lambda (thing) (object-p thing)) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 29ad980991b..a502901a469 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -1,6 +1,6 @@ ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -;; Copyright (C) 1996, 1998-2003, 2005, 2008-2013 Free Software +;; Copyright (C) 1996, 1998-2003, 2005, 2008-2014 Free Software ;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -74,108 +74,81 @@ Argument CH-PREFIX is another character prefix to display." ;;; CLASS COMPLETION / DOCUMENTATION -;;;###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. -Optional HEADERFCN should be called to insert a few bits of info first." - (interactive (list (eieio-read-class "Class: "))) - (with-output-to-temp-buffer (help-buffer) ;"*Help*" - (help-setup-xref (list #'eieio-describe-class class headerfcn) - (called-interactively-p 'interactive)) - - (when headerfcn (funcall headerfcn)) - (prin1 class) - (princ " is a") - (if (class-option class :abstract) - (princ "n abstract")) - (princ " class") - ;; Print file location - (when (get class 'class-location) - (princ " in `") - (princ (file-name-nondirectory (get class 'class-location))) - (princ "'")) - (terpri) - ;; Inheritance tree information - (let ((pl (eieio-class-parents class))) - (when pl - (princ " Inherits from ") - (while pl - (princ "`") (prin1 (car pl)) (princ "'") - (setq pl (cdr pl)) - (if pl (princ ", "))) - (terpri))) - (let ((ch (eieio-class-children class))) - (when ch - (princ " Children ") - (while ch - (princ "`") (prin1 (car ch)) (princ "'") - (setq ch (cdr ch)) - (if ch (princ ", "))) - (terpri))) - (terpri) - ;; System documentation - (let ((doc (documentation-property class 'variable-documentation))) - (when doc - (princ "Documentation:") - (terpri) - (princ doc) - (terpri) - (terpri))) - ;; Describe all the slots in this class - (eieio-describe-class-slots class) - ;; Describe all the methods specific to this class. - (let ((methods (eieio-all-generic-functions class)) - (doc nil)) - (if (not methods) nil - (princ "Specialized Methods:") - (terpri) - (terpri) - (while methods - (setq doc (eieio-method-documentation (car methods) class)) - (princ "`") - (prin1 (car methods)) - (princ "'") - (if (not doc) - (princ " Undocumented") - (if (car doc) - (progn - (princ " :STATIC ") - (prin1 (car (car doc))) - (terpri) - (princ (cdr (car doc))))) - (setq doc (cdr doc)) - (if (car doc) - (progn - (princ " :BEFORE ") - (prin1 (car (car doc))) - (terpri) - (princ (cdr (car doc))))) - (setq doc (cdr doc)) - (if (car doc) - (progn - (princ " :PRIMARY ") - (prin1 (car (car doc))) - (terpri) - (princ (cdr (car doc))))) - (setq doc (cdr doc)) - (if (car doc) - (progn - (princ " :AFTER ") - (prin1 (car (car doc))) - (terpri) - (princ (cdr (car doc))))) - (terpri) - (terpri)) - (setq methods (cdr methods)))))) - (with-current-buffer (help-buffer) - (buffer-string))) - -(defun eieio-describe-class-slots (class) - "Describe the slots in CLASS. -Outputs to the standard output." +(defun eieio-help-class (class) + "Print help description for CLASS. +If CLASS is actually an object, then also display current values of that object." + ;; Header line + (prin1 class) + (insert " is a" + (if (class-option class :abstract) + "n abstract" + "") + " class") + (let ((location (get class 'class-location))) + (when location + (insert " in `") + (help-insert-xref-button + (file-name-nondirectory location) + 'eieio-class-def class location) + (insert "'"))) + (insert ".\n") + ;; Parents + (let ((pl (eieio-class-parents class)) + cur) + (when pl + (insert " Inherits from ") + (while (setq cur (pop pl)) + (insert "`") + (help-insert-xref-button (symbol-name cur) + 'help-function cur) + (insert (if pl "', " "'"))) + (insert ".\n"))) + ;; Children + (let ((ch (eieio-class-children class)) + cur) + (when ch + (insert " Children ") + (while (setq cur (pop ch)) + (insert "`") + (help-insert-xref-button (symbol-name cur) + 'help-function cur) + (insert (if ch "', " "'"))) + (insert ".\n"))) + ;; System documentation + (let ((doc (documentation-property class 'variable-documentation))) + (when doc + (insert "\n" doc "\n\n"))) + ;; Describe all the slots in this class. + (eieio-help-class-slots class) + ;; Describe all the methods specific to this class. + (let ((methods (eieio-all-generic-functions class)) + (type [":STATIC" ":BEFORE" ":PRIMARY" ":AFTER"]) + counter doc) + (when methods + (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) + (while methods + (setq doc (eieio-method-documentation (car methods) class)) + (insert "`") + (help-insert-xref-button (symbol-name (car methods)) + 'help-function (car methods)) + (insert "'") + (if (not doc) + (insert " Undocumented") + (setq counter 0) + (dolist (cur doc) + (when cur + (insert " " (aref type counter) " " + (prin1-to-string (car cur) (current-buffer)) + "\n" + (cdr cur))) + (setq counter (1+ counter)))) + (insert "\n\n") + (setq methods (cdr methods)))))) + +(defun eieio-help-class-slots (class) + "Print help description for the slots in CLASS. +Outputs to the current buffer." (let* ((cv (class-v class)) (docs (eieio--class-public-doc cv)) (names (eieio--class-public-a cv)) @@ -185,28 +158,27 @@ Outputs to the standard output." (i 0) (prot (eieio--class-protection cv)) ) - (princ "Instance Allocated Slots:") - (terpri) - (terpri) + (insert (propertize "Instance Allocated Slots:\n\n" + 'face 'bold)) (while names - (if (car prot) (princ "Private ")) - (princ "Slot: ") - (prin1 (car names)) - (when (not (eq (aref types i) t)) - (princ " type = ") - (prin1 (aref types i))) - (unless (eq (car deflt) eieio-unbound) - (princ " default = ") - (prin1 (car deflt))) - (when (car publp) - (princ " printer = ") - (prin1 (car publp))) - (when (car docs) - (terpri) - (princ " ") - (princ (car docs)) - (terpri)) - (terpri) + (insert + (concat + (when (car prot) + (propertize "Private " 'face 'bold)) + (propertize "Slot: " 'face 'bold) + (prin1-to-string (car names)) + (unless (eq (aref types i) t) + (concat " type = " + (prin1-to-string (aref types i)))) + (unless (eq (car deflt) eieio-unbound) + (concat " default = " + (prin1-to-string (car deflt)))) + (when (car publp) + (concat " printer = " + (prin1-to-string (car publp)))) + (when (car docs) + (concat "\n " (car docs) "\n")) + "\n")) (setq names (cdr names) docs (cdr docs) deflt (cdr deflt) @@ -219,61 +191,30 @@ Outputs to the standard output." i 0 prot (eieio--class-class-allocation-protection cv)) (when names - (terpri) - (princ "Class Allocated Slots:")) - (terpri) - (terpri) + (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))) (while names - (when (car prot) - (princ "Private ")) - (princ "Slot: ") - (prin1 (car names)) - (unless (eq (aref types i) t) - (princ " type = ") - (prin1 (aref types i))) - (condition-case nil - (let ((value (eieio-oref class (car names)))) - (princ " value = ") - (prin1 value)) + (insert + (concat + (when (car prot) + "Private ") + "Slot: " + (prin1-to-string (car names)) + (unless (eq (aref types i) t) + (concat " type = " + (prin1-to-string (aref types i)))) + (condition-case nil + (let ((value (eieio-oref class (car names)))) + (concat " value = " + (prin1-to-string value))) (error nil)) - (when (car docs) - (terpri) - (princ " ") - (princ (car docs)) - (terpri)) - (terpri) + (when (car docs) + (concat "\n\n " (car docs) "\n")) + "\n")) (setq names (cdr names) docs (cdr docs) 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." - (interactive - ;; Use eieio-read-class since all constructors have the same name as - ;; the class they create. - (list (eieio-read-class "Class: "))) - (eieio-describe-class - fcn (lambda () - ;; Describe the constructor part. - (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) - (princ ".") - (terpri) - (terpri) - )) - ) - (defun eieio-build-class-list (class) "Return a list of all classes that inherit from CLASS." (if (class-p class) @@ -326,91 +267,112 @@ are not abstract." ;;; METHOD COMPLETION / DOC -(defalias 'describe-method 'eieio-describe-generic) -;;;###autoload(defalias 'describe-generic 'eieio-describe-generic) -(defalias 'eieio-describe-method 'eieio-describe-generic) +(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")) ;;;###autoload -(defun eieio-describe-generic (generic) - "Describe the generic function GENERIC. -Also extracts information about all methods specific to this generic." - (interactive (list (eieio-read-generic "Generic Method: "))) - (eieio--check-type generic-p generic) - (with-output-to-temp-buffer (help-buffer) ; "*Help*" - (help-setup-xref (list #'eieio-describe-generic generic) - (called-interactively-p 'interactive)) - - (prin1 generic) - (princ " is a generic function") - (when (generic-primary-only-p generic) - (princ " with only ") - (when (generic-primary-only-one-p generic) - (princ "one ")) - (princ "primary method") - (when (not (generic-primary-only-one-p generic)) - (princ "s")) - ) - (princ ".") - (terpri) - (terpri) - (let ((d (documentation generic))) - (if (not d) - (princ "The generic is not documented.\n") - (princ "Documentation:") - (terpri) - (princ d) - (terpri) - (terpri))) - (princ "Implementations:") - (terpri) - (terpri) - (let ((i 4) - (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) - ;; Loop over fanciful generics - (while (< i 7) - (let ((gm (aref (get generic 'eieio-method-tree) i))) - (when gm - (princ "Generic ") - (princ (aref prefix (- i 3))) - (terpri) - (princ (or (nth 2 gm) "Undocumented")) - (terpri) - (terpri))) - (setq i (1+ i))) - (setq i 0) - ;; Loop over defined class-specific methods - (while (< i 4) - (let ((gm (reverse (aref (get generic 'eieio-method-tree) i))) - location) - (while gm - (princ "`") - (prin1 (car (car gm))) - (princ "'") - ;; prefix type - (princ " ") - (princ (aref prefix i)) - (princ " ") - ;; argument list - (let* ((func (cdr (car gm))) - (arglst (eieio-lambda-arglist func))) - (prin1 arglst)) - (terpri) - ;; 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))) - (setq i (1+ i))))) - (with-current-buffer (help-buffer) - (buffer-string))) +(defun eieio-help-constructor (ctr) + "Describe CTR if it is a class constructor." + (when (class-p ctr) + (erase-buffer) + (let ((location (get ctr 'class-location)) + (def (symbol-function ctr))) + (goto-char (point-min)) + (prin1 ctr) + (insert (format " is an %s object constructor function" + (if (autoloadp def) + "autoloaded" + ""))) + (when (and (autoloadp def) + (null location)) + (setq location + (find-lisp-object-file-name ctr def))) + (when location + (insert " in `") + (help-insert-xref-button + (file-name-nondirectory location) + 'eieio-class-def ctr location) + (insert "'")) + (insert ".\nCreates an object of class " (symbol-name ctr) ".") + (goto-char (point-max)) + (if (autoloadp def) + (insert "\n\n[Class description not available until class definition is loaded.]\n") + (save-excursion + (insert (propertize "\n\nClass description:\n" 'face 'bold)) + (eieio-help-class ctr)) + )))) + + +;;;###autoload +(defun eieio-help-generic (generic) + "Describe GENERIC if it is a generic function." + (when (and (symbolp generic) (generic-p generic)) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward " in `.+'.$" nil t) + (replace-match "."))) + (save-excursion + (insert "\n\nThis is a generic function" + (cond + ((and (generic-primary-only-p generic) + (generic-primary-only-one-p generic)) + " with only one primary method") + ((generic-primary-only-p generic) + " with only primary methods") + (t "")) + ".\n\n") + (insert (propertize "Implementations:\n\n" 'face 'bold)) + (let ((i 4) + (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) + ;; Loop over fanciful generics + (while (< i 7) + (let ((gm (aref (get generic 'eieio-method-tree) i))) + (when gm + (insert "Generic " + (aref prefix (- i 3)) + "\n" + (or (nth 2 gm) "Undocumented") + "\n\n"))) + (setq i (1+ i))) + (setq i 0) + ;; Loop over defined class-specific methods + (while (< i 4) + (let* ((gm (reverse (aref (get generic 'eieio-method-tree) i))) + cname location) + (while gm + (setq cname (caar gm)) + (insert "`") + (help-insert-xref-button (symbol-name cname) + 'help-variable cname) + (insert "' " (aref prefix i) " ") + ;; argument list + (let* ((func (cdr (car gm))) + (arglst (eieio-lambda-arglist func))) + (prin1 arglst (current-buffer))) + (insert "\n" + (or (documentation (cdr (car gm))) + "Undocumented")) + ;; Print file location if available + (when (and (setq location (get generic 'method-locations)) + (setq location (assoc cname location))) + (setq location (cadr location)) + (insert "\n\nDefined in `") + (help-insert-xref-button + (file-name-nondirectory location) + 'eieio-method-def cname generic location) + (insert "'\n")) + (setq gm (cdr gm)) + (insert "\n"))) + (setq i (1+ i))))))) (defun eieio-lambda-arglist (func) "Return the argument list of FUNC, a function body." @@ -584,21 +546,13 @@ 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 (symbolp class) + (setq class (symbol-name class))) + (when (symbolp method) + (setq method (symbol-name method))) (when (null filename) (error "Cannot find library %s" file)) (setq buf (find-file-noselect filename)) @@ -622,6 +576,8 @@ Optional argument HISTORYVAR is the variable to use as history." (beginning-of-line)))) (defun eieio-help-find-class-definition (class file) + (when (symbolp class) + (setq class (symbol-name class))) (let ((filename (find-library-name file)) location buf) (when (null filename) @@ -642,71 +598,6 @@ Optional argument HISTORYVAR is the variable to use as history." (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." - ;; Scan created buttons so far if we are in help mode. - (when (eq major-mode 'help-mode) - (save-excursion - (goto-char (point-min)) - (let ((pos t) (inhibit-read-only t)) - (while pos - (if (get-text-property (point) 'help-xref) ; move off reference - (goto-char - (or (next-single-property-change (point) 'help-xref) - (point)))) - (setq pos (next-single-property-change (point) 'help-xref)) - (when pos - (goto-char pos) - (let* ((help-data (get-text-property (point) 'help-xref)) - ;(method (car help-data)) - (args (cdr help-data))) - (when (symbolp (car args)) - (cond ((class-p (car args)) - (setcar help-data 'eieio-describe-class)) - ((generic-p (car args)) - (setcar help-data 'eieio-describe-generic)) - (t nil)) - )))) - ;; start back at the beginning, and highlight some sections - (goto-char (point-min)) - (while (re-search-forward "^\\(Documentation\\|Implementations\\):$" nil t) - (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) - (goto-char (point-min)) - (if (re-search-forward "^Specialized Methods:$" nil t) - (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) - (goto-char (point-min)) - (while (re-search-forward "^\\(Instance\\|Class\\) Allocated Slots:$" nil t) - (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) - (goto-char (point-min)) - (while (re-search-forward ":\\(STATIC\\|BEFORE\\|AFTER\\|PRIMARY\\)" nil t) - (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) - (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 ;; @@ -749,7 +640,7 @@ DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the current expansion depth." (when (eq (point-min) (point-max)) ;; This function is only called once, to start the whole deal. - ;; Ceate, and expand the default object. + ;; Create and expand the default object. (eieio-class-button eieio-default-superclass 0) (forward-line -1) (speedbar-expand-line))) @@ -795,10 +686,14 @@ Argument INDENT is the depth of indentation." (defun eieio-describe-class-sb (text token indent) "Describe the class TEXT in TOKEN. INDENT is the current indentation level." - (speedbar-with-attached-buffer - (eieio-describe-class token)) - (speedbar-maybee-jump-to-attached-frame)) + (dframe-with-attached-buffer + (describe-function token)) + (dframe-maybee-jump-to-attached-frame)) (provide 'eieio-opt) +;; Local variables: +;; generated-autoload-file: "eieio.el" +;; End: + ;;; eieio-opt.el ends here diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index c230226eae4..85b9cc64a7d 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -1,6 +1,6 @@ ;;; eieio-speedbar.el -- Classes for managing speedbar displays. -;; Copyright (C) 1999-2002, 2005, 2007-2013 Free Software Foundation, +;; Copyright (C) 1999-2002, 2005, 2007-2014 Free Software Foundation, ;; Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -230,9 +230,9 @@ object edit buffer doing an in-place edit. If your object represents some other item, override this method and take the appropriate action." (require 'eieio-custom) - (speedbar-with-attached-buffer + (dframe-with-attached-buffer (eieio-customize-object object)) - (speedbar-maybee-jump-to-attached-frame)) + (dframe-maybee-jump-to-attached-frame)) ;;; Class definitions diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 37b1ec5fa94..a1b5b381571 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -1,7 +1,7 @@ ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects ;;; or maybe Eric's Implementation of Emacs Interpreted Objects -;; Copyright (C) 1995-1996, 1998-2013 Free Software Foundation, Inc. +;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 1.4 @@ -54,223 +54,7 @@ (interactive) (message eieio-version)) -(eval-and-compile -;; About the above. EIEIO must process its own code when it compiles -;; itself, thus, by eval-and-compiling ourselves, we solve the problem. - -;; Compatibility -(if (fboundp 'compiled-function-arglist) - - ;; XEmacs can only access a compiled functions arglist like this: - (defalias 'eieio-compiled-function-arglist 'compiled-function-arglist) - - ;; Emacs doesn't have this function, but since FUNC is a vector, we can just - ;; grab the appropriate element. - (defun eieio-compiled-function-arglist (func) - "Return the argument list for the compiled function FUNC." - (aref func 0)) - - ) - - -;;; -;; Variable declarations. -;; - -(defvar eieio-hook nil - "This hook is executed, then cleared each time `defclass' is called.") - -(defvar eieio-error-unsupported-class-tags nil - "Non-nil to throw an error if an encountered tag is unsupported. -This may prevent classes from CLOS applications from being used with EIEIO -since EIEIO does not support all CLOS tags.") - -(defvar eieio-skip-typecheck nil - "If non-nil, skip all slot typechecking. -Set this to t permanently if a program is functioning well to get a -small speed increase. This variable is also used internally to handle -default setting for optimization purposes.") - -(defvar eieio-optimize-primary-methods-flag t - "Non-nil means to optimize the method dispatch on primary methods.") - -(defvar eieio-initializing-object nil - "Set to non-nil while initializing an object.") - -(defconst eieio-unbound - (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) - eieio-unbound - (make-symbol "unbound")) - "Uninterned symbol representing an unbound slot in an object.") - -;; This is a bootstrap for eieio-default-superclass so it has a value -;; while it is being built itself. -(defvar eieio-default-superclass nil)) - -(defmacro eieio--define-field-accessors (prefix fields) - (declare (indent 1)) - (let ((index 0) - (defs '())) - (dolist (field fields) - (let ((doc (if (listp field) - (prog1 (cadr field) (setq field (car field)))))) - (push `(defmacro ,(intern (format "eieio--%s-%s" prefix field)) (x) - ,@(if doc (list (format (if (string-match "\n" doc) - "Return %s" "Return %s of a %s.") - doc prefix))) - (list 'aref x ,index)) - defs) - (setq index (1+ index)))) - `(eval-and-compile - ,@(nreverse defs) - (defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index)))) - -(eieio--define-field-accessors class - (-unused-0 ;;FIXME: not sure, but at least there was no accessor! - (symbol "symbol (self-referencing)") - parent children - (symbol-obarray "obarray permitting fast access to variable position indexes") - ;; @todo - ;; the word "public" here is leftovers from the very first version. - ;; Get rid of it! - (public-a "class attribute index") - (public-d "class attribute defaults index") - (public-doc "class documentation strings for attributes") - (public-type "class type for a slot") - (public-custom "class custom type for a slot") - (public-custom-label "class custom group for a slot") - (public-custom-group "class custom group for a slot") - (public-printer "printer for a slot") - (protection "protection for a slot") - (initarg-tuples "initarg tuples list") - (class-allocation-a "class allocated attributes") - (class-allocation-doc "class allocated documentation") - (class-allocation-type "class allocated value type") - (class-allocation-custom "class allocated custom descriptor") - (class-allocation-custom-label "class allocated custom descriptor") - (class-allocation-custom-group "class allocated custom group") - (class-allocation-printer "class allocated printer for a slot") - (class-allocation-protection "class allocated protection list") - (class-allocation-values "class allocated value vector") - (default-object-cache "what a newly created object would look like. -This will speed up instantiation time as only a `copy-sequence' will -be needed, instead of looping over all the values and setting them -from the default.") - (options "storage location of tagged class options. -Stored outright without modifications or stripping."))) - -(eieio--define-field-accessors object - (-unused-0 ;;FIXME: not sure, but at least there was no accessor! - (class "class struct defining OBJ") - name)) - -(eval-and-compile -;; FIXME: The constants below should have an `eieio-' prefix added!! - -(defconst method-static 0 "Index into :static tag on a method.") -(defconst method-before 1 "Index into :before tag on a method.") -(defconst method-primary 2 "Index into :primary tag on a method.") -(defconst method-after 3 "Index into :after tag on a method.") -(defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.") -(defconst method-generic-before 4 "Index into generic :before tag on a method.") -(defconst method-generic-primary 5 "Index into generic :primary tag on a method.") -(defconst method-generic-after 6 "Index into generic :after tag on a method.") -(defconst method-num-slots 7 "Number of indexes into a method's vector.") - -(defsubst eieio-specialized-key-to-generic-key (key) - "Convert a specialized KEY into a generic method key." - (cond ((eq key method-static) 0) ;; don't convert - ((< key method-num-lists) (+ key 3)) ;; The conversion - (t key) ;; already generic.. maybe. - )) - - -;;; Important macros used in eieio. -;; -(defmacro class-v (class) - "Internal: Return the class vector from the CLASS symbol." - ;; No check: If eieio gets this far, it's probably been checked already. - `(get ,class 'eieio-class-definition)) - -(defmacro class-p (class) - "Return t if CLASS is a valid class vector. -CLASS is a symbol." - ;; this new method is faster since it doesn't waste time checking lots of - ;; things. - `(condition-case nil - (eq (aref (class-v ,class) 0) 'defclass) - (error nil))) - -(defmacro eieio-object-p (obj) - "Return non-nil if OBJ is an EIEIO object." - `(condition-case nil - (let ((tobj ,obj)) - (and (eq (aref tobj 0) 'object) - (class-p (eieio--object-class tobj)))) - (error nil))) -(defalias 'object-p 'eieio-object-p) - -(defmacro class-constructor (class) - "Return the symbol representing the constructor of CLASS." - `(eieio--class-symbol (class-v ,class))) - -(defmacro generic-p (method) - "Return t if symbol METHOD is a generic function. -Only methods have the symbol `eieio-method-obarray' as a property -\(which contains a list of all bindings to that method type.)" - `(and (fboundp ,method) (get ,method 'eieio-method-obarray))) - -(defun generic-primary-only-p (method) - "Return t if symbol METHOD is a generic function with only primary methods. -Only methods have the symbol `eieio-method-obarray' as a property (which -contains a list of all bindings to that method type.) -Methods with only primary implementations are executed in an optimized way." - (and (generic-p method) - (let ((M (get method 'eieio-method-tree))) - (and (< 0 (length (aref M method-primary))) - (not (aref M method-static)) - (not (aref M method-before)) - (not (aref M method-after)) - (not (aref M method-generic-before)) - (not (aref M method-generic-primary)) - (not (aref M method-generic-after)))) - )) - -(defun generic-primary-only-one-p (method) - "Return t if symbol METHOD is a generic function with only primary methods. -Only methods have the symbol `eieio-method-obarray' as a property (which -contains a list of all bindings to that method type.) -Methods with only primary implementations are executed in an optimized way." - (and (generic-p method) - (let ((M (get method 'eieio-method-tree))) - (and (= 1 (length (aref M method-primary))) - (not (aref M method-static)) - (not (aref M method-before)) - (not (aref M method-after)) - (not (aref M method-generic-before)) - (not (aref M method-generic-primary)) - (not (aref M method-generic-after)))) - )) - -(defmacro class-option-assoc (list option) - "Return from LIST the found OPTION, or nil if it doesn't exist." - `(car-safe (cdr (memq ,option ,list)))) - -(defmacro class-option (class option) - "Return the value stored for CLASS' OPTION. -Return nil if that option doesn't exist." - `(class-option-assoc (eieio--class-options (class-v ,class)) ',option)) - -(defmacro class-abstract-p (class) - "Return non-nil if CLASS is abstract. -Abstract classes cannot be instantiated." - `(class-option ,class :abstract)) - -(defmacro class-method-invocation-order (class) - "Return the invocation order of CLASS. -Abstract classes cannot be instantiated." - `(or (class-option ,class :method-invocation-order) - :breadth-first)) +(require 'eieio-core) ;;; Defining a new class @@ -331,829 +115,13 @@ Options in CLOS not supported in EIEIO: Due to the way class options are set up, you can add any tags you wish, and reference them using the function `class-option'." - ;; We must `eval-and-compile' this so that when we byte compile - ;; an eieio program, there is no need to load it ahead of time. - ;; It also provides lots of nice debugging errors at compile time. + ;; This is eval-and-compile only to silence spurious compiler warnings + ;; about functions and variables not known to be defined. + ;; When eieio-defclass code is merged here and this becomes + ;; transparent to the compiler, the eval-and-compile can be removed. `(eval-and-compile (eieio-defclass ',name ',superclass ',slots ',options-and-doc))) -(defvar eieio-defclass-autoload-map (make-vector 7 nil) - "Symbol map of superclasses we find in autoloads.") - -;; We autoload this because it's used in `make-autoload'. -;;;###autoload -(defun eieio-defclass-autoload (cname superclasses filename doc) - "Create autoload symbols for the EIEIO class CNAME. -SUPERCLASSES are the superclasses that CNAME inherits from. -DOC is the docstring for CNAME. -This function creates a mock-class for CNAME and adds it into -SUPERCLASSES as children. -It creates an autoload function for CNAME's constructor." - ;; Assume we've already debugged inputs. - - (let* ((oldc (when (class-p cname) (class-v cname))) - (newc (make-vector eieio--class-num-slots nil)) - ) - (if oldc - nil ;; Do nothing if we already have this class. - - ;; Create the class in NEWC, but don't fill anything else in. - (aset newc 0 'defclass) - (setf (eieio--class-symbol newc) cname) - - (let ((clear-parent nil)) - ;; No parents? - (when (not superclasses) - (setq superclasses '(eieio-default-superclass) - clear-parent t) - ) - - ;; Hook our new class into the existing structures so we can - ;; autoload it later. - (dolist (SC superclasses) - - - ;; TODO - If we create an autoload that is in the map, that - ;; map needs to be cleared! - - - ;; Does our parent exist? - (if (not (class-p SC)) - - ;; Create a symbol for this parent, and then store this - ;; parent on that symbol. - (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map))) - (if (not (boundp sym)) - (set sym (list cname)) - (add-to-list sym cname)) - ) - - ;; We have a parent, save the child in there. - (when (not (member cname (eieio--class-children (class-v SC)))) - (setf (eieio--class-children (class-v SC)) - (cons cname (eieio--class-children (class-v SC)))))) - - ;; save parent in child - (setf (eieio--class-parent newc) (cons SC (eieio--class-parent newc))) - ) - - ;; turn this into a usable self-pointing symbol - (set cname cname) - - ;; Store the new class vector definition into the symbol. We need to - ;; do this first so that we can call defmethod for the accessor. - ;; The vector will be updated by the following while loop and will not - ;; need to be stored a second time. - (put cname 'eieio-class-definition newc) - - ;; Clear the parent - (if clear-parent (setf (eieio--class-parent newc) nil)) - - ;; Create an autoload on top of our constructor function. - (autoload cname filename doc nil nil) - (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) - (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) - (autoload (intern (concat (symbol-name cname) "-list-p")) filename "" nil nil) - - )))) - -(defsubst eieio-class-un-autoload (cname) - "If class CNAME is in an autoload state, load its file." - (when (eq (car-safe (symbol-function cname)) 'autoload) - (load-library (car (cdr (symbol-function cname)))))) - -(defmacro eieio--check-type (type obj) - (unless (symbolp obj) - (error "eieio--check-type wants OBJ to be a variable")) - `(if (not ,(cond - ((eq 'or (car-safe type)) - `(or ,@(mapcar (lambda (type) `(,type ,obj)) (cdr type)))) - (t `(,type ,obj)))) - (signal 'wrong-type-argument (list ',type ,obj)))) - -(defun eieio-defclass (cname superclasses slots options-and-doc) - ;; FIXME: Most of this should be moved to the `defclass' macro. - "Define CNAME as a new subclass of SUPERCLASSES. -SLOTS are the slots residing in that class definition, and options or -documentation OPTIONS-AND-DOC is the toplevel documentation for this class. -See `defclass' for more information." - ;; Run our eieio-hook each time, and clear it when we are done. - ;; This way people can add hooks safely if they want to modify eieio - ;; or add definitions when eieio is loaded or something like that. - (run-hooks 'eieio-hook) - (setq eieio-hook nil) - - (eieio--check-type listp superclasses) - - (let* ((pname superclasses) - (newc (make-vector eieio--class-num-slots nil)) - (oldc (when (class-p cname) (class-v cname))) - (groups nil) ;; list of groups id'd from slots - (options nil) - (clearparent nil)) - - (aset newc 0 'defclass) - (setf (eieio--class-symbol newc) cname) - - ;; If this class already existed, and we are updating its structure, - ;; make sure we keep the old child list. This can cause bugs, but - ;; if no new slots are created, it also saves time, and prevents - ;; method table breakage, particularly when the users is only - ;; byte compiling an EIEIO file. - (if oldc - (setf (eieio--class-children newc) (eieio--class-children oldc)) - ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. - ;; This is like the above, but deals with autoloads nicely. - (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) - (when sym - (condition-case nil - (setf (eieio--class-children newc) (symbol-value sym)) - (error nil)) - (unintern (symbol-name cname) eieio-defclass-autoload-map) - )) - ) - - (cond ((and (stringp (car options-and-doc)) - (/= 1 (% (length options-and-doc) 2))) - (error "Too many arguments to `defclass'")) - ((and (symbolp (car options-and-doc)) - (/= 0 (% (length options-and-doc) 2))) - (error "Too many arguments to `defclass'")) - ) - - (setq options - (if (stringp (car options-and-doc)) - (cons :documentation options-and-doc) - options-and-doc)) - - (if pname - (progn - (while pname - (if (and (car pname) (symbolp (car pname))) - (if (not (class-p (car pname))) - ;; bad class - (error "Given parent class %s is not a class" (car pname)) - ;; good parent class... - ;; save new child in parent - (when (not (member cname (eieio--class-children (class-v (car pname))))) - (setf (eieio--class-children (class-v (car pname))) - (cons cname (eieio--class-children (class-v (car pname)))))) - ;; Get custom groups, and store them into our local copy. - (mapc (lambda (g) (add-to-list 'groups g)) - (class-option (car pname) :custom-groups)) - ;; save parent in child - (setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc)))) - (error "Invalid parent class %s" pname)) - (setq pname (cdr pname))) - ;; Reverse the list of our parents so that they are prioritized in - ;; the same order as specified in the code. - (setf (eieio--class-parent newc) (nreverse (eieio--class-parent newc))) ) - ;; If there is nothing to loop over, then inherit from the - ;; default superclass. - (unless (eq cname 'eieio-default-superclass) - ;; adopt the default parent here, but clear it later... - (setq clearparent t) - ;; save new child in parent - (if (not (member cname (eieio--class-children (class-v 'eieio-default-superclass)))) - (setf (eieio--class-children (class-v 'eieio-default-superclass)) - (cons cname (eieio--class-children (class-v 'eieio-default-superclass))))) - ;; save parent in child - (setf (eieio--class-parent newc) (list eieio-default-superclass)))) - - ;; turn this into a usable self-pointing symbol - (set cname cname) - - ;; These two tests must be created right away so we can have self- - ;; referencing classes. ei, a class whose slot can contain only - ;; pointers to itself. - - ;; Create the test function - (let ((csym (intern (concat (symbol-name cname) "-p")))) - (fset csym - (list 'lambda (list 'obj) - (format "Test OBJ to see if it an object of type %s" cname) - (list 'and '(eieio-object-p obj) - (list 'same-class-p 'obj cname))))) - - ;; Make sure the method invocation order is a valid value. - (let ((io (class-option-assoc options :method-invocation-order))) - (when (and io (not (member io '(:depth-first :breadth-first :c3)))) - (error "Method invocation order %s is not allowed" io) - )) - - ;; Create a handy child test too - (let ((csym (intern (concat (symbol-name cname) "-child-p")))) - (fset csym - `(lambda (obj) - ,(format - "Test OBJ to see if it an object is a child of type %s" - cname) - (and (eieio-object-p obj) - (object-of-class-p obj ,cname)))) - - ;; Create a handy list of the class test too - (let ((csym (intern (concat (symbol-name cname) "-list-p")))) - (fset csym - `(lambda (obj) - ,(format - "Test OBJ to see if it a list of objects which are a child of type %s" - cname) - (when (listp obj) - (let ((ans t)) ;; nil is valid - ;; Loop over all the elements of the input list, test - ;; each to make sure it is a child of the desired object class. - (while (and obj ans) - (setq ans (and (eieio-object-p (car obj)) - (object-of-class-p (car obj) ,cname))) - (setq obj (cdr obj))) - ans))))) - - ;; When using typep, (typep OBJ 'myclass) returns t for objects which - ;; are subclasses of myclass. For our predicates, however, it is - ;; important for EIEIO to be backwards compatible, where - ;; myobject-p, and myobject-child-p are different. - ;; "cl" uses this technique to specify symbols with specific typep - ;; test, so we can let typep have the CLOS documented behavior - ;; while keeping our above predicate clean. - - ;; It would be cleaner to use `defsetf' here, but that requires cl - ;; at runtime. - (put cname 'cl-deftype-handler - (list 'lambda () `(list 'satisfies (quote ,csym))))) - - ;; Before adding new slots, let's add all the methods and classes - ;; in from the parent class. - (eieio-copy-parents-into-subclass newc superclasses) - - ;; Store the new class vector definition into the symbol. We need to - ;; do this first so that we can call defmethod for the accessor. - ;; The vector will be updated by the following while loop and will not - ;; need to be stored a second time. - (put cname 'eieio-class-definition newc) - - ;; Query each slot in the declaration list and mangle into the - ;; class structure I have defined. - (while slots - (let* ((slot1 (car slots)) - (name (car slot1)) - (slot (cdr slot1)) - (acces (plist-get slot ':accessor)) - (init (or (plist-get slot ':initform) - (if (member ':initform slot) nil - eieio-unbound))) - (initarg (plist-get slot ':initarg)) - (docstr (plist-get slot ':documentation)) - (prot (plist-get slot ':protection)) - (reader (plist-get slot ':reader)) - (writer (plist-get slot ':writer)) - (alloc (plist-get slot ':allocation)) - (type (plist-get slot ':type)) - (custom (plist-get slot ':custom)) - (label (plist-get slot ':label)) - (customg (plist-get slot ':group)) - (printer (plist-get slot ':printer)) - - (skip-nil (class-option-assoc options :allow-nil-initform)) - ) - - (if eieio-error-unsupported-class-tags - (let ((tmp slot)) - (while tmp - (if (not (member (car tmp) '(:accessor - :initform - :initarg - :documentation - :protection - :reader - :writer - :allocation - :type - :custom - :label - :group - :printer - :allow-nil-initform - :custom-groups))) - (signal 'invalid-slot-type (list (car tmp)))) - (setq tmp (cdr (cdr tmp)))))) - - ;; Clean up the meaning of protection. - (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil)) - ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) - ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) - ((eq prot nil) nil) - (t (signal 'invalid-slot-type (list ':protection prot)))) - - ;; Make sure the :allocation parameter has a valid value. - (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) - (signal 'invalid-slot-type (list ':allocation alloc))) - - ;; The default type specifier is supposed to be t, meaning anything. - (if (not type) (setq type t)) - - ;; Label is nil, or a string - (if (not (or (null label) (stringp label))) - (signal 'invalid-slot-type (list ':label label))) - - ;; Is there an initarg, but allocation of class? - (if (and initarg (eq alloc :class)) - (message "Class allocated slots do not need :initarg")) - - ;; intern the symbol so we can use it blankly - (if initarg (set initarg initarg)) - - ;; The customgroup should be a list of symbols - (cond ((null customg) - (setq customg '(default))) - ((not (listp customg)) - (setq customg (list customg)))) - ;; The customgroup better be a symbol, or list of symbols. - (mapc (lambda (cg) - (if (not (symbolp cg)) - (signal 'invalid-slot-type (list ':group cg)))) - customg) - - ;; First up, add this slot into our new class. - (eieio-add-new-slot newc name init docstr type custom label customg printer - prot initarg alloc 'defaultoverride skip-nil) - - ;; We need to id the group, and store them in a group list attribute. - (mapc (lambda (cg) (add-to-list 'groups cg)) customg) - - ;; Anyone can have an accessor function. This creates a function - ;; of the specified name, and also performs a `defsetf' if applicable - ;; so that users can `setf' the space returned by this function. - (if acces - (progn - (eieio--defmethod - acces (if (eq alloc :class) :static :primary) cname - `(lambda (this) - ,(format - "Retrieves the slot `%s' from an object of class `%s'" - name cname) - (if (slot-boundp this ',name) - (eieio-oref this ',name) - ;; Else - Some error? nil? - nil))) - - (if (fboundp 'gv-define-setter) - ;; FIXME: We should move more of eieio-defclass into the - ;; defclass macro so we don't have to use `eval' and require - ;; `gv' at run-time. - (eval `(gv-define-setter ,acces (eieio--store eieio--object) - (list 'eieio-oset eieio--object '',name - eieio--store))) - ;; Provide a setf method. It would be cleaner to use - ;; defsetf, but that would require CL at runtime. - (put acces 'setf-method - `(lambda (widget) - (let* ((--widget-sym-- (make-symbol "--widget--")) - (--store-sym-- (make-symbol "--store--"))) - (list - (list --widget-sym--) - (list widget) - (list --store-sym--) - (list 'eieio-oset --widget-sym-- '',name - --store-sym--) - (list 'getfoo --widget-sym--)))))))) - - ;; If a writer is defined, then create a generic method of that - ;; name whose purpose is to set the value of the slot. - (if writer - (eieio--defmethod - writer nil cname - `(lambda (this value) - ,(format "Set the slot `%s' of an object of class `%s'" - name cname) - (setf (slot-value this ',name) value)))) - ;; If a reader is defined, then create a generic method - ;; of that name whose purpose is to access this slot value. - (if reader - (eieio--defmethod - reader nil cname - `(lambda (this) - ,(format "Access the slot `%s' from object of class `%s'" - name cname) - (slot-value this ',name)))) - ) - (setq slots (cdr slots))) - - ;; Now that everything has been loaded up, all our lists are backwards! - ;; Fix that up now. - (setf (eieio--class-public-a newc) (nreverse (eieio--class-public-a newc))) - (setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc))) - (setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc newc))) - (setf (eieio--class-public-type newc) - (apply 'vector (nreverse (eieio--class-public-type newc)))) - (setf (eieio--class-public-custom newc) (nreverse (eieio--class-public-custom newc))) - (setf (eieio--class-public-custom-label newc) (nreverse (eieio--class-public-custom-label newc))) - (setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc))) - (setf (eieio--class-public-printer newc) (nreverse (eieio--class-public-printer newc))) - (setf (eieio--class-protection newc) (nreverse (eieio--class-protection newc))) - (setf (eieio--class-initarg-tuples newc) (nreverse (eieio--class-initarg-tuples newc))) - - ;; The storage for class-class-allocation-type needs to be turned into - ;; a vector now. - (setf (eieio--class-class-allocation-type newc) - (apply 'vector (eieio--class-class-allocation-type newc))) - - ;; Also, take class allocated values, and vectorize them for speed. - (setf (eieio--class-class-allocation-values newc) - (apply 'vector (eieio--class-class-allocation-values newc))) - - ;; Attach slot symbols into an obarray, and store the index of - ;; this slot as the variable slot in this new symbol. We need to - ;; know about primes, because obarrays are best set in vectors of - ;; prime number length, and we also need to make our vector small - ;; to save space, and also optimal for the number of items we have. - (let* ((cnt 0) - (pubsyms (eieio--class-public-a newc)) - (prots (eieio--class-protection newc)) - (l (length pubsyms)) - (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47 - 53 59 61 67 71 73 79 83 89 97 101 ))) - (while (and primes (< (car primes) l)) - (setq primes (cdr primes))) - (car primes))) - (oa (make-vector vl 0)) - (newsym)) - (while pubsyms - (setq newsym (intern (symbol-name (car pubsyms)) oa)) - (set newsym cnt) - (setq cnt (1+ cnt)) - (if (car prots) (put newsym 'protection (car prots))) - (setq pubsyms (cdr pubsyms) - prots (cdr prots))) - (setf (eieio--class-symbol-obarray newc) oa) - ) - - ;; Create the constructor function - (if (class-option-assoc options :abstract) - ;; Abstract classes cannot be instantiated. Say so. - (let ((abs (class-option-assoc options :abstract))) - (if (not (stringp abs)) - (setq abs (format "Class %s is abstract" cname))) - (fset cname - `(lambda (&rest stuff) - ,(format "You cannot create a new object of type %s" cname) - (error ,abs)))) - - ;; Non-abstract classes need a constructor. - (fset cname - `(lambda (newname &rest slots) - ,(format "Create a new object with name NAME of class type %s" cname) - (apply 'constructor ,cname newname slots))) - ) - - ;; Set up a specialized doc string. - ;; Use stored value since it is calculated in a non-trivial way - (put cname 'variable-documentation - (class-option-assoc options :documentation)) - - ;; Save the file location where this class is defined. - (let ((fname (if load-in-progress - load-file-name - buffer-file-name)) - 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) - (if (memq :custom-groups options) - (setcar (cdr (memq :custom-groups options)) g) - (setq options (cons :custom-groups (cons g options))))) - - ;; Set up the options we have collected. - (setf (eieio--class-options newc) options) - - ;; if this is a superclass, clear out parent (which was set to the - ;; default superclass eieio-default-superclass) - (if clearparent (setf (eieio--class-parent newc) nil)) - - ;; Create the cached default object. - (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) 3) - nil))) - (aset cache 0 'object) - (setf (eieio--object-class cache) cname) - (setf (eieio--object-name cache) 'default-cache-object) - (let ((eieio-skip-typecheck t)) - ;; All type-checking has been done to our satisfaction - ;; before this call. Don't waste our time in this call.. - (eieio-set-defaults cache t)) - (setf (eieio--class-default-object-cache newc) cache)) - - ;; Return our new class object - ;; newc - cname - )) - -(defun eieio-perform-slot-validation-for-default (slot spec value skipnil) - "For SLOT, signal if SPEC does not match VALUE. -If SKIPNIL is non-nil, then if VALUE is nil return t instead." - (if (and (not (eieio-eval-default-p value)) - (not eieio-skip-typecheck) - (not (and skipnil (null value))) - (not (eieio-perform-slot-validation spec value))) - (signal 'invalid-slot-type (list slot spec value)))) - -(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc - &optional defaultoverride skipnil) - "Add into NEWC attribute A. -If A already exists in NEWC, then do nothing. If it doesn't exist, -then also add in D (default), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg. -Argument ALLOC specifies if the slot is allocated per instance, or per class. -If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, -we must override its value for a default. -Optional argument SKIPNIL indicates if type checking should be skipped -if default value is nil." - ;; Make sure we duplicate those items that are sequences. - (condition-case nil - (if (sequencep d) (setq d (copy-sequence d))) - ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work. - (error nil)) - (if (sequencep type) (setq type (copy-sequence type))) - (if (sequencep cust) (setq cust (copy-sequence cust))) - (if (sequencep custg) (setq custg (copy-sequence custg))) - - ;; To prevent override information w/out specification of storage, - ;; we need to do this little hack. - (if (member a (eieio--class-class-allocation-a newc)) (setq alloc ':class)) - - (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) - ;; In this case, we modify the INSTANCE version of a given slot. - - (progn - - ;; Only add this element if it is so-far unique - (if (not (member a (eieio--class-public-a newc))) - (progn - (eieio-perform-slot-validation-for-default a type d skipnil) - (setf (eieio--class-public-a newc) (cons a (eieio--class-public-a newc))) - (setf (eieio--class-public-d newc) (cons d (eieio--class-public-d newc))) - (setf (eieio--class-public-doc newc) (cons doc (eieio--class-public-doc newc))) - (setf (eieio--class-public-type newc) (cons type (eieio--class-public-type newc))) - (setf (eieio--class-public-custom newc) (cons cust (eieio--class-public-custom newc))) - (setf (eieio--class-public-custom-label newc) (cons label (eieio--class-public-custom-label newc))) - (setf (eieio--class-public-custom-group newc) (cons custg (eieio--class-public-custom-group newc))) - (setf (eieio--class-public-printer newc) (cons print (eieio--class-public-printer newc))) - (setf (eieio--class-protection newc) (cons prot (eieio--class-protection newc))) - (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) - ) - ;; When defaultoverride is true, we are usually adding new local - ;; attributes which must override the default value of any slot - ;; passed in by one of the parent classes. - (when defaultoverride - ;; There is a match, and we must override the old value. - (let* ((ca (eieio--class-public-a newc)) - (np (member a ca)) - (num (- (length ca) (length np))) - (dp (if np (nthcdr num (eieio--class-public-d newc)) - nil)) - (tp (if np (nth num (eieio--class-public-type newc)))) - ) - (if (not np) - (error "EIEIO internal error overriding default value for %s" - a) - ;; If type is passed in, is it the same? - (if (not (eq type t)) - (if (not (equal type tp)) - (error - "Child slot type `%s' does not match inherited type `%s' for `%s'" - type tp a))) - ;; If we have a repeat, only update the initarg... - (unless (eq d eieio-unbound) - (eieio-perform-slot-validation-for-default a tp d skipnil) - (setcar dp d)) - ;; If we have a new initarg, check for it. - (when init - (let* ((inits (eieio--class-initarg-tuples newc)) - (inita (rassq a inits))) - ;; Replace the CAR of the associate INITA. - ;;(message "Initarg: %S replace %s" inita init) - (setcar inita init) - )) - - ;; PLN Tue Jun 26 11:57:06 2007 : The protection is - ;; checked and SHOULD match the superclass - ;; protection. Otherwise an error is thrown. However - ;; I wonder if a more flexible schedule might be - ;; implemented. - ;; - ;; EML - We used to have (if prot... here, - ;; but a prot of 'nil means public. - ;; - (let ((super-prot (nth num (eieio--class-protection newc))) - ) - (if (not (eq prot super-prot)) - (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" - prot super-prot a))) - ;; End original PLN - - ;; PLN Tue Jun 26 11:57:06 2007 : - ;; Do a non redundant combination of ancient custom - ;; groups and new ones. - (when custg - (let* ((groups - (nthcdr num (eieio--class-public-custom-group newc))) - (list1 (car groups)) - (list2 (if (listp custg) custg (list custg)))) - (if (< (length list1) (length list2)) - (setq list1 (prog1 list2 (setq list2 list1)))) - (dolist (elt list2) - (unless (memq elt list1) - (push elt list1))) - (setcar groups list1))) - ;; End PLN - - ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is - ;; set, simply replaces the old one. - (when cust - ;; (message "Custom type redefined to %s" cust) - (setcar (nthcdr num (eieio--class-public-custom newc)) cust)) - - ;; If a new label is specified, it simply replaces - ;; the old one. - (when label - ;; (message "Custom label redefined to %s" label) - (setcar (nthcdr num (eieio--class-public-custom-label newc)) label)) - ;; End PLN - - ;; PLN Sat Jun 30 17:24:42 2007 : when a new - ;; doc is specified, simply replaces the old one. - (when doc - ;;(message "Documentation redefined to %s" doc) - (setcar (nthcdr num (eieio--class-public-doc newc)) - doc)) - ;; End PLN - - ;; If a new printer is specified, it simply replaces - ;; the old one. - (when print - ;; (message "printer redefined to %s" print) - (setcar (nthcdr num (eieio--class-public-printer newc)) print)) - - ))) - )) - - ;; CLASS ALLOCATED SLOTS - (let ((value (eieio-default-eval-maybe d))) - (if (not (member a (eieio--class-class-allocation-a newc))) - (progn - (eieio-perform-slot-validation-for-default a type value skipnil) - ;; Here we have found a :class version of a slot. This - ;; requires a very different approach. - (setf (eieio--class-class-allocation-a newc) (cons a (eieio--class-class-allocation-a newc))) - (setf (eieio--class-class-allocation-doc newc) (cons doc (eieio--class-class-allocation-doc newc))) - (setf (eieio--class-class-allocation-type newc) (cons type (eieio--class-class-allocation-type newc))) - (setf (eieio--class-class-allocation-custom newc) (cons cust (eieio--class-class-allocation-custom newc))) - (setf (eieio--class-class-allocation-custom-label newc) (cons label (eieio--class-class-allocation-custom-label newc))) - (setf (eieio--class-class-allocation-custom-group newc) (cons custg (eieio--class-class-allocation-custom-group newc))) - (setf (eieio--class-class-allocation-protection newc) (cons prot (eieio--class-class-allocation-protection newc))) - ;; Default value is stored in the 'values section, since new objects - ;; can't initialize from this element. - (setf (eieio--class-class-allocation-values newc) (cons value (eieio--class-class-allocation-values newc)))) - (when defaultoverride - ;; There is a match, and we must override the old value. - (let* ((ca (eieio--class-class-allocation-a newc)) - (np (member a ca)) - (num (- (length ca) (length np))) - (dp (if np - (nthcdr num - (eieio--class-class-allocation-values newc)) - nil)) - (tp (if np (nth num (eieio--class-class-allocation-type newc)) - nil))) - (if (not np) - (error "EIEIO internal error overriding default value for %s" - a) - ;; If type is passed in, is it the same? - (if (not (eq type t)) - (if (not (equal type tp)) - (error - "Child slot type `%s' does not match inherited type `%s' for `%s'" - type tp a))) - ;; EML - Note: the only reason to override a class bound slot - ;; is to change the default, so allow unbound in. - - ;; If we have a repeat, only update the value... - (eieio-perform-slot-validation-for-default a tp value skipnil) - (setcar dp value)) - - ;; PLN Tue Jun 26 11:57:06 2007 : The protection is - ;; checked and SHOULD match the superclass - ;; protection. Otherwise an error is thrown. However - ;; I wonder if a more flexible schedule might be - ;; implemented. - (let ((super-prot - (car (nthcdr num (eieio--class-class-allocation-protection newc))))) - (if (not (eq prot super-prot)) - (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" - prot super-prot a))) - ;; Do a non redundant combination of ancient custom groups - ;; and new ones. - (when custg - (let* ((groups - (nthcdr num (eieio--class-class-allocation-custom-group newc))) - (list1 (car groups)) - (list2 (if (listp custg) custg (list custg)))) - (if (< (length list1) (length list2)) - (setq list1 (prog1 list2 (setq list2 list1)))) - (dolist (elt list2) - (unless (memq elt list1) - (push elt list1))) - (setcar groups list1))) - - ;; PLN Sat Jun 30 17:24:42 2007 : when a new - ;; doc is specified, simply replaces the old one. - (when doc - ;;(message "Documentation redefined to %s" doc) - (setcar (nthcdr num (eieio--class-class-allocation-doc newc)) - doc)) - ;; End PLN - - ;; If a new printer is specified, it simply replaces - ;; the old one. - (when print - ;; (message "printer redefined to %s" print) - (setcar (nthcdr num (eieio--class-class-allocation-printer newc)) print)) - - )) - )) - )) - -(defun eieio-copy-parents-into-subclass (newc parents) - "Copy into NEWC the slots of PARENTS. -Follow the rules of not overwriting early parents when applying to -the new child class." - (let ((ps (eieio--class-parent newc)) - (sn (class-option-assoc (eieio--class-options newc) - ':allow-nil-initform))) - (while ps - ;; First, duplicate all the slots of the parent. - (let ((pcv (class-v (car ps)))) - (let ((pa (eieio--class-public-a pcv)) - (pd (eieio--class-public-d pcv)) - (pdoc (eieio--class-public-doc pcv)) - (ptype (eieio--class-public-type pcv)) - (pcust (eieio--class-public-custom pcv)) - (plabel (eieio--class-public-custom-label pcv)) - (pcustg (eieio--class-public-custom-group pcv)) - (printer (eieio--class-public-printer pcv)) - (pprot (eieio--class-protection pcv)) - (pinit (eieio--class-initarg-tuples pcv)) - (i 0)) - (while pa - (eieio-add-new-slot newc - (car pa) (car pd) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) (car-safe (car pinit)) nil nil sn) - ;; Increment each value. - (setq pa (cdr pa) - pd (cdr pd) - pdoc (cdr pdoc) - i (1+ i) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - pinit (cdr pinit)) - )) ;; while/let - ;; Now duplicate all the class alloc slots. - (let ((pa (eieio--class-class-allocation-a pcv)) - (pdoc (eieio--class-class-allocation-doc pcv)) - (ptype (eieio--class-class-allocation-type pcv)) - (pcust (eieio--class-class-allocation-custom pcv)) - (plabel (eieio--class-class-allocation-custom-label pcv)) - (pcustg (eieio--class-class-allocation-custom-group pcv)) - (printer (eieio--class-class-allocation-printer pcv)) - (pprot (eieio--class-class-allocation-protection pcv)) - (pval (eieio--class-class-allocation-values pcv)) - (i 0)) - (while pa - (eieio-add-new-slot newc - (car pa) (aref pval i) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) nil ':class sn) - ;; Increment each value. - (setq pa (cdr pa) - pdoc (cdr pdoc) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - i (1+ i)) - ))) ;; while/let - ;; Loop over each parent class - (setq ps (cdr ps))) - )) ;;; CLOS style implementation of object creators. ;; @@ -1187,17 +155,6 @@ a string." ;;; CLOS methods and generics ;; - -(put 'eieio--defalias 'byte-hunk-handler - #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) -(defun eieio--defalias (name body) - "Like `defalias', but with less side-effects. -More specifically, it has no side-effects at all when the new function -definition is the same (`eq') as the old one." - (unless (and (fboundp name) - (eq (symbol-function name) body)) - (defalias name body))) - (defmacro defgeneric (method args &optional doc-string) "Create a generic function METHOD. DOC-STRING is the base documentation for this class. A generic @@ -1209,115 +166,6 @@ top level documentation to a method." `(eieio--defalias ',method (eieio--defgeneric-init-form ',method ,doc-string))) -(defun eieio--defgeneric-init-form (method doc-string) - "Form to use for the initial definition of a generic." - (cond - ((or (not (fboundp method)) - (eq 'autoload (car-safe (symbol-function method)))) - ;; Make sure the method tables are installed. - (eieiomt-install method) - ;; Construct the actual body of this function. - (eieio-defgeneric-form method doc-string)) - ((generic-p method) (symbol-function method)) ;Leave it as-is. - (t (error "You cannot create a generic/method over an existing symbol: %s" - method)))) - -(defun eieio-defgeneric-form (method doc-string) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD." - `(lambda (&rest local-args) - ,doc-string - (eieio-generic-call (quote ,method) local-args))) - -(defsubst eieio-defgeneric-reset-generic-form (method) - "Setup METHOD to call the generic form." - (let ((doc-string (documentation method))) - (fset method (eieio-defgeneric-form method doc-string)))) - -(defun eieio-defgeneric-form-primary-only (method doc-string) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD." - `(lambda (&rest local-args) - ,doc-string - (eieio-generic-call-primary-only (quote ,method) local-args))) - -(defsubst eieio-defgeneric-reset-generic-form-primary-only (method) - "Setup METHOD to call the generic form." - (let ((doc-string (documentation method))) - (fset method (eieio-defgeneric-form-primary-only method doc-string)))) - -(defun eieio-defgeneric-form-primary-only-one (method doc-string - class - impl - ) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD. -CLASS is the class symbol needed for private method access. -IMPL is the symbol holding the method implementation." - ;; NOTE: I tried out byte compiling this little fcn. Turns out it - ;; is faster to execute this for not byte-compiled. ie, install this, - ;; then measure calls going through here. I wonder why. - (require 'bytecomp) - (let ((byte-compile-warnings nil)) - (byte-compile - `(lambda (&rest local-args) - ,doc-string - ;; This is a cool cheat. Usually we need to look up in the - ;; method table to find out if there is a method or not. We can - ;; instead make that determination at load time when there is - ;; only one method. If the first arg is not a child of the class - ;; of that one implementation, then clearly, there is no method def. - (if (not (eieio-object-p (car local-args))) - ;; Not an object. Just signal. - (signal 'no-method-definition - (list ',method local-args)) - - ;; We do have an object. Make sure it is the right type. - (if ,(if (eq class eieio-default-superclass) - nil ; default superclass means just an obj. Already asked. - `(not (child-of-class-p (eieio--object-class (car local-args)) - ',class))) - - ;; If not the right kind of object, call no applicable - (apply 'no-applicable-method (car local-args) - ',method local-args) - - ;; It is ok, do the call. - ;; Fill in inter-call variables then evaluate the method. - (let ((scoped-class ',class) - (eieio-generic-call-next-method-list nil) - (eieio-generic-call-key method-primary) - (eieio-generic-call-methodname ',method) - (eieio-generic-call-arglst local-args) - ) - ,(if (< emacs-major-version 24) - `(apply ,(list 'quote impl) local-args) - `(apply #',impl local-args)) - ;(,impl local-args) - ))))))) - -(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) - "Setup METHOD to call the generic form." - (let* ((doc-string (documentation method)) - (M (get method 'eieio-method-tree)) - (entry (car (aref M method-primary))) - ) - (fset method (eieio-defgeneric-form-primary-only-one - method doc-string - (car entry) - (cdr entry) - )))) - -(defun eieio-unbind-method-implementations (method) - "Make the generic method METHOD have no implementations. -It will leave the original generic function in place, -but remove reference to all implementations of METHOD." - (put method 'eieio-method-tree nil) - (put method 'eieio-method-obarray nil)) - (defmacro defmethod (method &rest args) "Create a new METHOD through `defgeneric' with ARGS. @@ -1358,139 +206,6 @@ Summary: (format "Generically created method `%s'." method))) (eieio--defmethod ',method ',key ',class #',code)))) -(defun eieio--defmethod (method kind argclass code) - "Work part of the `defmethod' macro defining METHOD with ARGS." - (let ((key - ;; Find optional keys. - (cond ((memq kind '(:BEFORE :before)) method-before) - ((memq kind '(:AFTER :after)) method-after) - ((memq kind '(:STATIC :static)) method-static) - ((memq kind '(:PRIMARY :primary nil)) method-primary) - ;; Primary key. - ;; (t method-primary) - (t (error "Unknown method kind %S" kind))))) - ;; Make sure there is a generic (when called from defclass). - (eieio--defalias - method (eieio--defgeneric-init-form - method (or (documentation code) - (format "Generically created method `%s'." method)))) - ;; Create symbol for property to bind to. If the first arg is of - ;; the form (varname vartype) and `vartype' is a class, then - ;; that class will be the type symbol. If not, then it will fall - ;; under the type `primary' which is a non-specific calling of the - ;; function. - (if argclass - (if (not (class-p argclass)) - (error "Unknown class type %s in method parameters" - argclass)) - ;; Generics are higher. - (setq key (eieio-specialized-key-to-generic-key key))) - ;; Put this lambda into the symbol so we can find it. - (eieiomt-add method code key argclass) - ) - - (when eieio-optimize-primary-methods-flag - ;; Optimizing step: - ;; - ;; If this method, after this setup, only has primary methods, then - ;; we can setup the generic that way. - (if (generic-primary-only-p method) - ;; If there is only one primary method, then we can go one more - ;; optimization step. - (if (generic-primary-only-one-p method) - (eieio-defgeneric-reset-generic-form-primary-only-one method) - (eieio-defgeneric-reset-generic-form-primary-only method)) - (eieio-defgeneric-reset-generic-form method))) - - method) - -;;; Slot type validation - -;; This is a hideous hack for replacing `typep' from cl-macs, to avoid -;; requiring the CL library at run-time. It can be eliminated if/when -;; `typep' is merged into Emacs core. -(defun eieio--typep (val type) - (if (symbolp type) - (cond ((get type 'cl-deftype-handler) - (eieio--typep val (funcall (get type 'cl-deftype-handler)))) - ((eq type t) t) - ((eq type 'null) (null val)) - ((eq type 'atom) (atom val)) - ((eq type 'float) (and (numberp val) (not (integerp val)))) - ((eq type 'real) (numberp val)) - ((eq type 'fixnum) (integerp val)) - ((memq type '(character string-char)) (characterp val)) - (t - (let* ((name (symbol-name type)) - (namep (intern (concat name "p")))) - (if (fboundp namep) - (funcall `(lambda () (,namep val))) - (funcall `(lambda () - (,(intern (concat name "-p")) val))))))) - (cond ((get (car type) 'cl-deftype-handler) - (eieio--typep val (apply (get (car type) 'cl-deftype-handler) - (cdr type)))) - ((memq (car type) '(integer float real number)) - (and (eieio--typep val (car type)) - (or (memq (cadr type) '(* nil)) - (if (consp (cadr type)) - (> val (car (cadr type))) - (>= val (cadr type)))) - (or (memq (caddr type) '(* nil)) - (if (consp (car (cddr type))) - (< val (caar (cddr type))) - (<= val (car (cddr type))))))) - ((memq (car type) '(and or not)) - (eval (cons (car type) - (mapcar (lambda (x) - `(eieio--typep (quote ,val) (quote ,x))) - (cdr type))))) - ((memq (car type) '(member member*)) - (memql val (cdr type))) - ((eq (car type) 'satisfies) - (funcall `(lambda () (,(cadr type) val)))) - (t (error "Bad type spec: %s" type))))) - -(defun eieio-perform-slot-validation (spec value) - "Return non-nil if SPEC does not match VALUE." - (or (eq spec t) ; t always passes - (eq value eieio-unbound) ; unbound always passes - (eieio--typep value spec))) - -(defun eieio-validate-slot-value (class slot-idx value slot) - "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. -Checks the :type specifier. -SLOT is the slot that is being checked, and is only used when throwing -an error." - (if eieio-skip-typecheck - nil - ;; Trim off object IDX junk added in for the object index. - (setq slot-idx (- slot-idx 3)) - (let ((st (aref (eieio--class-public-type (class-v class)) slot-idx))) - (if (not (eieio-perform-slot-validation st value)) - (signal 'invalid-slot-type (list class slot st value)))))) - -(defun eieio-validate-class-slot-value (class slot-idx value slot) - "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. -Checks the :type specifier. -SLOT is the slot that is being checked, and is only used when throwing -an error." - (if eieio-skip-typecheck - nil - (let ((st (aref (eieio--class-class-allocation-type (class-v class)) - slot-idx))) - (if (not (eieio-perform-slot-validation st value)) - (signal 'invalid-slot-type (list class slot st value)))))) - -(defun eieio-barf-if-slot-unbound (value instance slotname fn) - "Throw a signal if VALUE is a representation of an UNBOUND slot. -INSTANCE is the object being referenced. SLOTNAME is the offending -slot. If the slot is ok, return VALUE. -Argument FN is the function calling this verifier." - (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) - (slot-unbound instance (eieio-object-class instance) slotname fn) - value)) - ;;; Get/Set slots in an object. ;; (defmacro oref (obj slot) @@ -1499,28 +214,6 @@ Slot is the name of the slot when created by `defclass' or the label created by the :initarg tag." `(eieio-oref ,obj (quote ,slot))) -(defun eieio-oref (obj slot) - "Return the value in OBJ at SLOT in the object vector." - (eieio--check-type (or eieio-object-p class-p) obj) - (eieio--check-type symbolp slot) - (if (class-p obj) (eieio-class-un-autoload obj)) - (let* ((class (if (class-p obj) obj (eieio--object-class obj))) - (c (eieio-slot-name-index class obj slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c (eieio-class-slot-name-index class slot)) - ;; Oref that slot. - (aref (eieio--class-class-allocation-values (class-v class)) c) - ;; The slot-missing method is a cool way of allowing an object author - ;; to intercept missing slot definitions. Since it is also the LAST - ;; thing called in this fn, its return value would be retrieved. - (slot-missing obj slot 'oref) - ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) - ) - (eieio--check-type eieio-object-p obj) - (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) - (defalias 'slot-value 'eieio-oref) (defalias 'set-slot-value 'eieio-oset) @@ -1531,45 +224,6 @@ tag. SLOT can be the slot name, or the tag specified by the :initarg tag in the `defclass' call." `(eieio-oref-default ,obj (quote ,slot))) -(defun eieio-oref-default (obj slot) - "Do the work for the macro `oref-default' with similar parameters. -Fills in OBJ's SLOT with its default value." - (eieio--check-type (or eieio-object-p class-p) obj) - (eieio--check-type symbolp slot) - (let* ((cl (if (eieio-object-p obj) (eieio--object-class obj) obj)) - (c (eieio-slot-name-index cl obj slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c - (eieio-class-slot-name-index cl slot)) - ;; Oref that slot. - (aref (eieio--class-class-allocation-values (class-v cl)) - c) - (slot-missing obj slot 'oref-default) - ;;(signal 'invalid-slot-name (list (class-name cl) slot)) - ) - (eieio-barf-if-slot-unbound - (let ((val (nth (- c 3) (eieio--class-public-d (class-v cl))))) - (eieio-default-eval-maybe val)) - obj cl 'oref-default)))) - -(defsubst eieio-eval-default-p (val) - "Whether the default value VAL should be evaluated for use." - (and (consp val) (symbolp (car val)) (fboundp (car val)))) - -(defun eieio-default-eval-maybe (val) - "Check VAL, and return what `oref-default' would provide." - (cond - ;; Is it a function call? If so, evaluate it. - ((eieio-eval-default-p val) - (eval val)) - ;;;; check for quoted things, and unquote them - ;;((and (consp val) (eq (car val) 'quote)) - ;; (car (cdr val))) - ;; return it verbatim - (t val))) - ;;; Handy CLOS macros ;; (defmacro with-slots (spec-list object &rest body) @@ -1607,13 +261,6 @@ variable name of the same name as the slot." (define-obsolete-function-alias 'object-class-fast #'eieio--object-class "24.4") -(defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS." - (eieio--check-type class-p class) - ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, - ;; and I wanted a string. Arg! - (format "#<class %s>" (symbol-name class))) -(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") - (defun eieio-object-name (obj &optional extra) "Return a Lisp like symbol string for object OBJ. If EXTRA, include that in the string returned to represent the symbol." @@ -1650,10 +297,6 @@ If EXTRA, include that in the string returned to represent the symbol." (define-obsolete-function-alias 'object-class-name 'eieio-object-class-name "24.4") -(defmacro eieio-class-parents-fast (class) - "Return parent classes to CLASS with no check." - `(eieio--class-parent (class-v ,class))) - (defun eieio-class-parents (class) "Return parent classes to CLASS. (overload of variable). @@ -1662,130 +305,14 @@ The CLOS function `class-direct-superclasses' is aliased to this function." (eieio-class-parents-fast class)) (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") -(defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check." - `(eieio--class-children (class-v ,class))) - (defun eieio-class-children (class) "Return child classes to CLASS. - The CLOS function `class-direct-subclasses' is aliased to this function." (eieio--check-type class-p class) (eieio-class-children-fast class)) (define-obsolete-function-alias 'class-children #'eieio-class-children "24.4") -(defun eieio-c3-candidate (class remaining-inputs) - "Return CLASS if it can go in the result now, otherwise nil" - ;; Ensure CLASS is not in any position but the first in any of the - ;; element lists of REMAINING-INPUTS. - (and (not (let ((found nil)) - (while (and remaining-inputs (not found)) - (setq found (member class (cdr (car remaining-inputs))) - remaining-inputs (cdr remaining-inputs))) - found)) - class)) - -(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) - "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. -If a consistent order does not exist, signal an error." - (if (let ((tail remaining-inputs) - (found nil)) - (while (and tail (not found)) - (setq found (car tail) tail (cdr tail))) - (not found)) - ;; If all remaining inputs are empty lists, we are done. - (nreverse reversed-partial-result) - ;; Otherwise, we try to find the next element of the result. This - ;; is achieved by considering the first element of each - ;; (non-empty) input list and accepting a candidate if it is - ;; consistent with the rests of the input lists. - (let* ((found nil) - (tail remaining-inputs) - (next (progn - (while (and tail (not found)) - (setq found (and (car tail) - (eieio-c3-candidate (caar tail) - remaining-inputs)) - tail (cdr tail))) - found))) - (if next - ;; The graph is consistent so far, add NEXT to result and - ;; merge input lists, dropping NEXT from their heads where - ;; applicable. - (eieio-c3-merge-lists - (cons next reversed-partial-result) - (mapcar (lambda (l) (if (eq (first l) next) (rest l) l)) - remaining-inputs)) - ;; The graph is inconsistent, give up - (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) - -(defun eieio-class-precedence-dfs (class) - "Return all parents of CLASS in depth-first order." - (let* ((parents (eieio-class-parents-fast class)) - (classes (copy-sequence - (apply #'append - (list class) - (or - (mapcar - (lambda (parent) - (cons parent - (eieio-class-precedence-dfs parent))) - parents) - '((eieio-default-superclass)))))) - (tail classes)) - ;; Remove duplicates. - (while tail - (setcdr tail (delq (car tail) (cdr tail))) - (setq tail (cdr tail))) - classes)) - -(defun eieio-class-precedence-bfs (class) - "Return all parents of CLASS in breadth-first order." - (let ((result) - (queue (or (eieio-class-parents-fast class) - '(eieio-default-superclass)))) - (while queue - (let ((head (pop queue))) - (unless (member head result) - (push head result) - (unless (eq head 'eieio-default-superclass) - (setq queue (append queue (or (eieio-class-parents-fast head) - '(eieio-default-superclass)))))))) - (cons class (nreverse result))) - ) - -(defun eieio-class-precedence-c3 (class) - "Return all parents of CLASS in c3 order." - (let ((parents (eieio-class-parents-fast class))) - (eieio-c3-merge-lists - (list class) - (append - (or - (mapcar - (lambda (x) - (eieio-class-precedence-c3 x)) - parents) - '((eieio-default-superclass))) - (list parents)))) - ) - -(defun eieio-class-precedence-list (class) - "Return (transitively closed) list of parents of CLASS. -The order, in which the parents are returned depends on the -method invocation orders of the involved classes." - (if (or (null class) (eq class 'eieio-default-superclass)) - nil - (case (class-method-invocation-order class) - (:depth-first - (eieio-class-precedence-dfs class)) - (:breadth-first - (eieio-class-precedence-bfs class)) - (:c3 - (eieio-class-precedence-c3 class)))) - ) -(define-obsolete-function-alias - 'class-precedence-list 'eieio-class-precedence-list "24.4") - ;; Official CLOS functions. (define-obsolete-function-alias 'class-direct-superclasses #'eieio-class-parents "24.4") @@ -1795,11 +322,7 @@ method invocation orders of the involved classes." (defmacro eieio-class-parent (class) "Return first parent class to CLASS. (overload of variable)." `(car (eieio-class-parents ,class))) -(define-obsolete-function-alias 'class-parent #'eieio-class-parent "24.4") - -(defmacro same-class-fast-p (obj class) - "Return t if OBJ is of class-type CLASS with no error checking." - `(eq (eieio--object-class ,obj) ,class)) +(define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4") (defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." (eieio--check-type class-p class) @@ -1848,29 +371,6 @@ 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." - (eieio--check-type eieio-object-p obj) - (eieio--check-type symbolp slot) - (let ((c (eieio-slot-name-index (eieio--object-class obj) obj slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c - (eieio-class-slot-name-index (eieio--object-class obj) slot)) - ;; Oset that slot. - (progn - (eieio-validate-class-slot-value (eieio--object-class obj) c value slot) - (aset (eieio--class-class-allocation-values (class-v (eieio--object-class obj))) - c value)) - ;; See oref for comment on `slot-missing' - (slot-missing obj slot 'oset value) - ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) - ) - (eieio-validate-slot-value (eieio--object-class obj) c value slot) - (aset obj c value)))) - (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 @@ -1878,32 +378,6 @@ 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." - (eieio--check-type class-p class) - (eieio--check-type 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 (eieio--class-class-allocation-values (class-v class)) c - value)) - (signal 'invalid-slot-name (list (eieio-class-name class) slot))) - (eieio-validate-slot-value class c value slot) - ;; Set this into the storage for defaults. - (setcar (nthcdr (- c 3) (eieio--class-public-d (class-v class))) - value) - ;; Take the value, and put it into our cache object. - (eieio-oset (eieio--class-default-object-cache (class-v class)) - slot value) - ))) - ;;; CLOS queries into classes and slots ;; (defun slot-boundp (object slot) @@ -2019,337 +493,9 @@ If SLOT is unbound, do nothing." (if (not (slot-boundp object slot)) nil (eieio-oset object slot (delete item (eieio-oref object slot))))) - -;;; EIEIO internal search functions -;; -(defun eieio-slot-originating-class-p (start-class slot) - "Return non-nil if START-CLASS is the first class to define SLOT. -This is for testing if `scoped-class' is the class that defines SLOT -so that we can protect private slots." - (let ((par (eieio-class-parents start-class)) - (ret t)) - (if (not par) - t - (while (and par ret) - (if (intern-soft (symbol-name slot) - (eieio--class-symbol-obarray (class-v (car par)))) - (setq ret nil)) - (setq par (cdr par))) - ret))) - -(defun eieio-slot-name-index (class obj slot) - "In CLASS for OBJ find the index of the named SLOT. -The slot is a symbol which is installed in CLASS by the `defclass' -call. OBJ can be nil, but if it is an object, and the slot in question -is protected, access will be allowed if OBJ is a child of the currently -`scoped-class'. -If SLOT is the value created with :initarg instead, -reverse-lookup that name, and recurse with the associated slot value." - ;; Removed checks to outside this call - (let* ((fsym (intern-soft (symbol-name slot) - (eieio--class-symbol-obarray (class-v class)))) - (fsi (if (symbolp fsym) (symbol-value fsym) nil))) - (if (integerp fsi) - (cond - ((not (get fsym 'protection)) - (+ 3 fsi)) - ((and (eq (get fsym 'protection) 'protected) - (bound-and-true-p scoped-class) - (or (child-of-class-p class scoped-class) - (and (eieio-object-p obj) - (child-of-class-p class (eieio-object-class obj))))) - (+ 3 fsi)) - ((and (eq (get fsym 'protection) 'private) - (or (and (bound-and-true-p scoped-class) - (eieio-slot-originating-class-p scoped-class slot)) - eieio-initializing-object)) - (+ 3 fsi)) - (t nil)) - (let ((fn (eieio-initarg-to-attribute class slot))) - (if fn (eieio-slot-name-index class obj fn) nil))))) - -(defun eieio-class-slot-name-index (class slot) - "In CLASS find the index of the named SLOT. -The slot is a symbol which is installed in CLASS by the `defclass' -call. If SLOT is the value created with :initarg instead, -reverse-lookup that name, and recurse with the associated slot value." - ;; This will happen less often, and with fewer slots. Do this the - ;; storage cheap way. - (let* ((a (eieio--class-class-allocation-a (class-v class))) - (l1 (length a)) - (af (memq slot a)) - (l2 (length af))) - ;; Slot # is length of the total list, minus the remaining list of - ;; the found slot. - (if af (- l1 l2)))) - -;;; CLOS generics internal function handling -;; -(defvar eieio-generic-call-methodname nil - "When using `call-next-method', provides a context on how to do it.") -(defvar eieio-generic-call-arglst nil - "When using `call-next-method', provides a context for parameters.") -(defvar eieio-generic-call-key nil - "When using `call-next-method', provides a context for the current key. -Keys are a number representing :before, :primary, and :after methods.") -(defvar eieio-generic-call-next-method-list nil - "When executing a PRIMARY or STATIC method, track the 'next-method'. -During executions, the list is first generated, then as each next method -is called, the next method is popped off the stack.") - -(define-obsolete-variable-alias 'eieio-pre-method-execution-hooks - 'eieio-pre-method-execution-functions "24.3") -(defvar eieio-pre-method-execution-functions nil - "Abnormal hook run just before an EIEIO method is executed. -The hook function must accept one argument, the list of forms -about to be executed.") - -(defun eieio-generic-call (method args) - "Call METHOD with ARGS. -ARGS provides the context on which implementation to use. -This should only be called from a generic function." - ;; We must expand our arguments first as they are always - ;; passed in as quoted symbols - (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) - (eieio-generic-call-methodname method) - (eieio-generic-call-arglst args) - (firstarg nil) - (primarymethodlist nil)) - ;; get a copy - (setq newargs args - firstarg (car newargs)) - ;; Is the class passed in autoloaded? - ;; Since class names are also constructors, they can be autoloaded - ;; via the autoload command. Check for this, and load them in. - ;; It's ok if it doesn't turn out to be a class. Probably want that - ;; function loaded anyway. - (if (and (symbolp firstarg) - (fboundp firstarg) - (listp (symbol-function firstarg)) - (eq 'autoload (car (symbol-function firstarg)))) - (load (nth 1 (symbol-function firstarg)))) - ;; Determine the class to use. - (cond ((eieio-object-p firstarg) - (setq mclass (eieio--object-class firstarg))) - ((class-p firstarg) - (setq mclass firstarg)) - ) - ;; Make sure the class is a valid class - ;; mclass can be nil (meaning a generic for should be used. - ;; mclass cannot have a value that is not a class, however. - (when (and (not (null mclass)) (not (class-p mclass))) - (error "Cannot dispatch method %S on class %S" - method mclass) - ) - ;; Now create a list in reverse order of all the calls we have - ;; make in order to successfully do this right. Rules: - ;; 1) Only call generics if scoped-class is not defined - ;; This prevents multiple calls in the case of recursion - ;; 2) Only call static if this is a static method. - ;; 3) Only call specifics if the definition allows for them. - ;; 4) Call in order based on :before, :primary, and :after - (when (eieio-object-p firstarg) - ;; Non-static calls do all this stuff. - - ;; :after methods - (setq tlambdas - (if mclass - (eieiomt-method-list method method-after mclass) - (list (eieio-generic-form method method-after nil))) - ;;(or (and mclass (eieio-generic-form method method-after mclass)) - ;; (eieio-generic-form method method-after nil)) - ) - (setq lambdas (append tlambdas lambdas) - keys (append (make-list (length tlambdas) method-after) keys)) - - ;; :primary methods - (setq tlambdas - (or (and mclass (eieio-generic-form method method-primary mclass)) - (eieio-generic-form method method-primary nil))) - (when tlambdas - (setq lambdas (cons tlambdas lambdas) - keys (cons method-primary keys) - primarymethodlist - (eieiomt-method-list method method-primary mclass))) - - ;; :before methods - (setq tlambdas - (if mclass - (eieiomt-method-list method method-before mclass) - (list (eieio-generic-form method method-before nil))) - ;;(or (and mclass (eieio-generic-form method method-before mclass)) - ;; (eieio-generic-form method method-before nil)) - ) - (setq lambdas (append tlambdas lambdas) - keys (append (make-list (length tlambdas) method-before) keys)) - ) - - (if mclass - ;; For the case of a class, - ;; if there were no methods found, then there could be :static methods. - (when (not lambdas) - (setq tlambdas - (eieio-generic-form method method-static mclass)) - (setq lambdas (cons tlambdas lambdas) - keys (cons method-static keys) - primarymethodlist ;; Re-use even with bad name here - (eieiomt-method-list method method-static mclass))) - ;; For the case of no class (ie - mclass == nil) then there may - ;; be a primary method. - (setq tlambdas - (eieio-generic-form method method-primary nil)) - (when tlambdas - (setq lambdas (cons tlambdas lambdas) - keys (cons method-primary keys) - primarymethodlist - (eieiomt-method-list method method-primary nil))) - ) - - (run-hook-with-args 'eieio-pre-method-execution-functions - primarymethodlist) - - ;; Now loop through all occurrences forms which we must execute - ;; (which are happily sorted now) and execute them all! - (let ((rval nil) (lastval nil) (rvalever nil) (found nil)) - (while lambdas - (if (car lambdas) - (let* ((scoped-class (cdr (car lambdas))) - (eieio-generic-call-key (car keys)) - (has-return-val - (or (= eieio-generic-call-key method-primary) - (= eieio-generic-call-key method-static))) - (eieio-generic-call-next-method-list - ;; Use the cdr, as the first element is the fcn - ;; we are calling right now. - (when has-return-val (cdr primarymethodlist))) - ) - (setq found t) - ;;(setq rval (apply (car (car lambdas)) newargs)) - (setq lastval (apply (car (car lambdas)) newargs)) - (when has-return-val - (setq rval lastval - rvalever t)) - )) - (setq lambdas (cdr lambdas) - keys (cdr keys))) - (if (not found) - (if (eieio-object-p (car args)) - (setq rval (apply 'no-applicable-method (car args) method args) - rvalever t) - (signal - 'no-method-definition - (list method args)))) - ;; Right Here... it could be that lastval is returned when - ;; rvalever is nil. Is that right? - rval))) - -(defun eieio-generic-call-primary-only (method args) - "Call METHOD with ARGS for methods with only :PRIMARY implementations. -ARGS provides the context on which implementation to use. -This should only be called from a generic function. - -This method is like `eieio-generic-call', but only -implementations in the :PRIMARY slot are queried. After many -years of use, it appears that over 90% of methods in use -have :PRIMARY implementations only. We can therefore optimize -for this common case to improve performance." - ;; We must expand our arguments first as they are always - ;; passed in as quoted symbols - (let ((newargs nil) (mclass nil) (lambdas nil) - (eieio-generic-call-methodname method) - (eieio-generic-call-arglst args) - (firstarg nil) - (primarymethodlist nil) - ) - ;; get a copy - (setq newargs args - firstarg (car newargs)) - - ;; Determine the class to use. - (cond ((eieio-object-p firstarg) - (setq mclass (eieio--object-class firstarg))) - ((not firstarg) - (error "Method %s called on nil" method)) - ((not (eieio-object-p firstarg)) - (error "Primary-only method %s called on something not an object" method)) - (t - (error "EIEIO Error: Improperly classified method %s as primary only" - method) - )) - ;; Make sure the class is a valid class - ;; mclass can be nil (meaning a generic for should be used. - ;; mclass cannot have a value that is not a class, however. - (when (null mclass) - (error "Cannot dispatch method %S on class %S" method mclass) - ) - - ;; :primary methods - (setq lambdas (eieio-generic-form method method-primary mclass)) - (setq primarymethodlist ;; Re-use even with bad name here - (eieiomt-method-list method method-primary mclass)) - - ;; Now loop through all occurrences forms which we must execute - ;; (which are happily sorted now) and execute them all! - (let* ((rval nil) (lastval nil) (rvalever nil) - (scoped-class (cdr lambdas)) - (eieio-generic-call-key method-primary) - ;; Use the cdr, as the first element is the fcn - ;; we are calling right now. - (eieio-generic-call-next-method-list (cdr primarymethodlist)) - ) - - (if (or (not lambdas) (not (car lambdas))) - - ;; No methods found for this impl... - (if (eieio-object-p (car args)) - (setq rval (apply 'no-applicable-method (car args) method args) - rvalever t) - (signal - 'no-method-definition - (list method args))) - - ;; Do the regular implementation here. - - (run-hook-with-args 'eieio-pre-method-execution-functions - lambdas) - - (setq lastval (apply (car lambdas) newargs)) - (setq rval lastval - rvalever t) - ) - ;; Right Here... it could be that lastval is returned when - ;; rvalever is nil. Is that right? - rval))) - -(defun eieiomt-method-list (method key class) - "Return an alist list of methods lambdas. -METHOD is the method name. -KEY represents either :before, or :after methods. -CLASS is the starting class to search from in the method tree. -If CLASS is nil, then an empty list of methods should be returned." - ;; Note: eieiomt - the MT means MethodTree. See more comments below - ;; for the rest of the eieiomt methods. - - ;; Collect lambda expressions stored for the class and its parent - ;; classes. - (let (lambdas) - (dolist (ancestor (eieio-class-precedence-list class)) - ;; Lookup the form to use for the PRIMARY object for the next level - (let ((tmpl (eieio-generic-form method key ancestor))) - (when (and tmpl - (or (not lambdas) - ;; This prevents duplicates coming out of the - ;; class method optimizer. Perhaps we should - ;; just not optimize before/afters? - (not (member tmpl lambdas)))) - (push tmpl lambdas)))) - - ;; Return collected lambda. For :after methods, return in current - ;; order (most general class last); Otherwise, reverse order. - (if (eq key method-after) - lambdas - (nreverse lambdas)))) +;;; +;; Method Calling Functions (defun next-method-p () "Return non-nil if there is a next method. @@ -2367,7 +513,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 (bound-and-true-p scoped-class)) + (if (not (eieio--scoped-class)) (error "`call-next-method' not called within a class specific method")) (if (and (/= eieio-generic-call-key method-primary) (/= eieio-generic-call-key method-static)) @@ -2381,231 +527,10 @@ Use `next-method-p' to find out if there is a next method to call." (let* ((eieio-generic-call-next-method-list (cdr eieio-generic-call-next-method-list)) (eieio-generic-call-arglst newargs) - (scoped-class (cdr next)) (fcn (car next)) ) - (apply fcn newargs) - )))) - -;;; -;; eieio-method-tree : eieiomt- -;; -;; Stored as eieio-method-tree in property list of a generic method -;; -;; (eieio-method-tree . [BEFORE PRIMARY AFTER -;; genericBEFORE genericPRIMARY genericAFTER]) -;; and -;; (eieio-method-obarray . [BEFORE PRIMARY AFTER -;; genericBEFORE genericPRIMARY genericAFTER]) -;; where the association is a vector. -;; (aref 0 -- all static methods. -;; (aref 1 -- all methods classified as :before -;; (aref 2 -- all methods classified as :primary -;; (aref 3 -- all methods classified as :after -;; (aref 4 -- a generic classified as :before -;; (aref 5 -- a generic classified as :primary -;; (aref 6 -- a generic classified as :after -;; -(defvar eieiomt-optimizing-obarray nil - "While mapping atoms, this contain the obarray being optimized.") - -(defun eieiomt-install (method-name) - "Install the method tree, and obarray onto METHOD-NAME. -Do not do the work if they already exist." - (let ((emtv (get method-name 'eieio-method-tree)) - (emto (get method-name 'eieio-method-obarray))) - (if (or (not emtv) (not emto)) - (progn - (setq emtv (put method-name 'eieio-method-tree - (make-vector method-num-slots nil)) - emto (put method-name 'eieio-method-obarray - (make-vector method-num-slots nil))) - (aset emto 0 (make-vector 11 0)) - (aset emto 1 (make-vector 11 0)) - (aset emto 2 (make-vector 41 0)) - (aset emto 3 (make-vector 11 0)) - )))) - -(defun eieiomt-add (method-name method key class) - "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. -METHOD-NAME is the name created by a call to `defgeneric'. -METHOD are the forms for a given implementation. -KEY is an integer (see comment in eieio.el near this function) which -is associated with the :static :before :primary and :after tags. -It also indicates if CLASS is defined or not. -CLASS is the class this method is associated with." - (if (or (> key method-num-slots) (< key 0)) - (error "eieiomt-add: method key error!")) - (let ((emtv (get method-name 'eieio-method-tree)) - (emto (get method-name 'eieio-method-obarray))) - ;; Make sure the method tables are available. - (if (or (not emtv) (not emto)) - (error "Programmer error: eieiomt-add")) - ;; only add new cells on if it doesn't already exist! - (if (assq class (aref emtv key)) - (setcdr (assq class (aref emtv key)) method) - (aset emtv key (cons (cons class method) (aref emtv key)))) - ;; Add function definition into newly created symbol, and store - ;; said symbol in the correct obarray, otherwise use the - ;; other array to keep this stuff - (if (< key method-num-lists) - (let ((nsym (intern (symbol-name class) (aref emto key)))) - (fset nsym method))) - ;; 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))) - ;; @todo - Is this overkill? Should we just clear the symbol? - (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray))) - )) - -(defun eieiomt-next (class) - "Return the next parent class for CLASS. -If CLASS is a superclass, return variable `eieio-default-superclass'. -If CLASS is variable `eieio-default-superclass' then return nil. -This is different from function `class-parent' as class parent returns -nil for superclasses. This function performs no type checking!" - ;; No type-checking because all calls are made from functions which - ;; are safe and do checking for us. - (or (eieio-class-parents-fast class) - (if (eq class 'eieio-default-superclass) - nil - '(eieio-default-superclass)))) - -(defun eieiomt-sym-optimize (s) - "Find the next class above S which has a function body for the optimizer." - ;; Set the value to nil in case there is no nearest cell. - (set s nil) - ;; Find the nearest cell that has a function body. If we find one, - ;; we replace the nil from above. - (let ((external-symbol (intern-soft (symbol-name s)))) - (catch 'done - (dolist (ancestor (rest (eieio-class-precedence-list external-symbol))) - (let ((ov (intern-soft (symbol-name ancestor) - eieiomt-optimizing-obarray))) - (when (fboundp ov) - (set s ov) ;; store ov as our next symbol - (throw 'done ancestor))))))) - -(defun eieio-generic-form (method key class) - "Return the lambda form belonging to METHOD using KEY based upon CLASS. -If CLASS is not a class then use `generic' instead. If class has -no form, but has a parent class, then trace to that parent class. -The first time a form is requested from a symbol, an optimized path -is memorized for faster future use." - (let ((emto (aref (get method 'eieio-method-obarray) - (if class key (eieio-specialized-key-to-generic-key key))))) - (if (class-p class) - ;; 1) find our symbol - (let ((cs (intern-soft (symbol-name class) emto))) - (if (not cs) - ;; 2) If there isn't one, then make one. - ;; This can be slow since it only occurs once - (progn - (setq cs (intern (symbol-name class) emto)) - ;; 2.1) Cache its nearest neighbor with a quick optimize - ;; which should only occur once for this call ever - (let ((eieiomt-optimizing-obarray emto)) - (eieiomt-sym-optimize cs)))) - ;; 3) If it's bound return this one. - (if (fboundp cs) - (cons cs (eieio--class-symbol (class-v class))) - ;; 4) If it's not bound then this variable knows something - (if (symbol-value cs) - (progn - ;; 4.1) This symbol holds the next class in its value - (setq class (symbol-value cs) - cs (intern-soft (symbol-name class) emto)) - ;; 4.2) The optimizer should always have chosen a - ;; function-symbol - ;;(if (fboundp cs) - (cons cs (eieio--class-symbol (class-v (intern (symbol-name class))))) - ;;(error "EIEIO optimizer: erratic data loss!")) - ) - ;; There never will be a funcall... - nil))) - ;; for a generic call, what is a list, is the function body we want. - (let ((emtl (aref (get method 'eieio-method-tree) - (if class key (eieio-specialized-key-to-generic-key key))))) - (if emtl - ;; The car of EMTL is supposed to be a class, which in this - ;; case is nil, so skip it. - (cons (cdr (car emtl)) nil) - nil))))) - -;;; -;; Way to assign slots based on a list. Used for constructors, or -;; even resetting an object at run-time -;; -(defun eieio-set-defaults (obj &optional set-all) - "Take object OBJ, and reset all slots to their defaults. -If SET-ALL is non-nil, then when a default is nil, that value is -reset. If SET-ALL is nil, the slots are only reset if the default is -not nil." - (let ((scoped-class (eieio--object-class obj)) - (eieio-initializing-object t) - (pub (eieio--class-public-a (class-v (eieio--object-class obj))))) - (while pub - (let ((df (eieio-oref-default obj (car pub)))) - (if (or df set-all) - (eieio-oset obj (car pub) df))) - (setq pub (cdr pub))))) - -(defun eieio-initarg-to-attribute (class initarg) - "For CLASS, convert INITARG to the actual attribute name. -If there is no translation, pass it in directly (so we can cheat if -need be... May remove that later...)" - (let ((tuple (assoc initarg (eieio--class-initarg-tuples (class-v class))))) - (if tuple - (cdr tuple) - nil))) - -(defun eieio-attribute-to-initarg (class attribute) - "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. -This is usually a symbol that starts with `:'." - (let ((tuple (rassoc attribute (eieio--class-initarg-tuples (class-v class))))) - (if tuple - (car tuple) - nil))) - - -;;; Here are some special types of errors -;; -(intern "no-method-definition") -(put 'no-method-definition 'error-conditions '(no-method-definition error)) -(put 'no-method-definition 'error-message "No method definition") - -(intern "no-next-method") -(put 'no-next-method 'error-conditions '(no-next-method error)) -(put 'no-next-method 'error-message "No next method") - -(intern "invalid-slot-name") -(put 'invalid-slot-name 'error-conditions '(invalid-slot-name error)) -(put 'invalid-slot-name 'error-message "Invalid slot name") - -(intern "invalid-slot-type") -(put 'invalid-slot-type 'error-conditions '(invalid-slot-type error nil)) -(put 'invalid-slot-type 'error-message "Invalid slot type") - -(intern "unbound-slot") -(put 'unbound-slot 'error-conditions '(unbound-slot error nil)) -(put 'unbound-slot 'error-message "Unbound slot") - -(intern "inconsistent-class-hierarchy") -(put 'inconsistent-class-hierarchy 'error-conditions - '(inconsistent-class-hierarchy error nil)) -(put 'inconsistent-class-hierarchy 'error-message "Inconsistent class hierarchy") + (eieio--with-scoped-class (cdr next) + (apply fcn newargs)) )))) ;;; Here are some CLOS items that need the CL package ;; @@ -2678,7 +603,7 @@ Called from the constructor routine.") (defmethod shared-initialize ((obj eieio-default-superclass) slots) "Set slots of OBJ with SLOTS which is a list of name/value pairs. Called from the constructor routine." - (let ((scoped-class (eieio--object-class obj))) + (eieio--with-scoped-class (eieio--object-class obj) (while slots (let ((rn (eieio-initarg-to-attribute (eieio--object-class obj) (car slots)))) @@ -2700,27 +625,27 @@ call `shared-initialize' yourself, or you can call `call-next-method' to have this constructor called automatically. If these steps are not taken, then new objects of your class will not have their values dynamically set from SLOTS." - ;; First, see if any of our defaults are `lambda', and - ;; re-evaluate them and apply the value to our slots. - (let* ((scoped-class (class-v (eieio--object-class this))) - (slot (eieio--class-public-a scoped-class)) - (defaults (eieio--class-public-d scoped-class))) - (while slot - ;; For each slot, see if we need to evaluate it. - ;; - ;; Paul Landes said in an email: - ;; > CL evaluates it if it can, and otherwise, leaves it as - ;; > the quoted thing as you already have. This is by the - ;; > Sonya E. Keene book and other things I've look at on the - ;; > web. - (let ((dflt (eieio-default-eval-maybe (car defaults)))) - (when (not (eq dflt (car defaults))) - (eieio-oset this (car slot) dflt) )) - ;; Next. - (setq slot (cdr slot) - defaults (cdr defaults)))) - ;; Shared initialize will parse our slots for us. - (shared-initialize this slots)) + ;; First, see if any of our defaults are `lambda', and + ;; re-evaluate them and apply the value to our slots. + (let* ((this-class (class-v (eieio--object-class this))) + (slot (eieio--class-public-a this-class)) + (defaults (eieio--class-public-d this-class))) + (while slot + ;; For each slot, see if we need to evaluate it. + ;; + ;; Paul Landes said in an email: + ;; > CL evaluates it if it can, and otherwise, leaves it as + ;; > the quoted thing as you already have. This is by the + ;; > Sonya E. Keene book and other things I've look at on the + ;; > web. + (let ((dflt (eieio-default-eval-maybe (car defaults)))) + (when (not (eq dflt (car defaults))) + (eieio-oset this (car slot) dflt) )) + ;; Next. + (setq slot (cdr slot) + defaults (cdr defaults)))) + ;; Shared initialize will parse our slots for us. + (shared-initialize this slots)) (defgeneric slot-missing (object slot-name operation &optional new-value) "Method invoked when an attempt to access a slot in OBJECT fails.") @@ -2940,101 +865,9 @@ This may create or delete slots, but does not affect the return value of `eq'." (error "EIEIO: `change-class' is unimplemented")) -) - -;;; Obsolete backward compatibility functions. -;; Needed to run byte-code compiled with the EIEIO of Emacs-23. - -(defun eieio-defmethod (method args) - "Obsolete work part of an old version of the `defmethod' macro." - (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) - ;; find optional keys - (setq key - (cond ((memq (car args) '(:BEFORE :before)) - (setq args (cdr args)) - method-before) - ((memq (car args) '(:AFTER :after)) - (setq args (cdr args)) - method-after) - ((memq (car args) '(:STATIC :static)) - (setq args (cdr args)) - method-static) - ((memq (car args) '(:PRIMARY :primary)) - (setq args (cdr args)) - method-primary) - ;; Primary key. - (t method-primary))) - ;; Get body, and fix contents of args to be the arguments of the fn. - (setq body (cdr args) - args (car args)) - (setq loopa args) - ;; Create a fixed version of the arguments. - (while loopa - (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) - argfix)) - (setq loopa (cdr loopa))) - ;; Make sure there is a generic. - (eieio-defgeneric - method - (if (stringp (car body)) - (car body) (format "Generically created method `%s'." method))) - ;; create symbol for property to bind to. If the first arg is of - ;; the form (varname vartype) and `vartype' is a class, then - ;; that class will be the type symbol. If not, then it will fall - ;; under the type `primary' which is a non-specific calling of the - ;; function. - (setq firstarg (car args)) - (if (listp firstarg) - (progn - (setq argclass (nth 1 firstarg)) - (if (not (class-p argclass)) - (error "Unknown class type %s in method parameters" - (nth 1 firstarg)))) - ;; Generics are higher. - (setq key (eieio-specialized-key-to-generic-key key))) - ;; Put this lambda into the symbol so we can find it. - (if (byte-code-function-p (car-safe body)) - (eieiomt-add method (car-safe body) key argclass) - (eieiomt-add method (append (list 'lambda (reverse argfix)) body) - key argclass)) - ) - - (when eieio-optimize-primary-methods-flag - ;; Optimizing step: - ;; - ;; If this method, after this setup, only has primary methods, then - ;; we can setup the generic that way. - (if (generic-primary-only-p method) - ;; If there is only one primary method, then we can go one more - ;; optimization step. - (if (generic-primary-only-one-p method) - (eieio-defgeneric-reset-generic-form-primary-only-one method) - (eieio-defgeneric-reset-generic-form-primary-only method)) - (eieio-defgeneric-reset-generic-form method))) - - method) -(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1") - -(defun eieio-defgeneric (method doc-string) - "Obsolete work part of an old version of the `defgeneric' macro." - (if (and (fboundp method) (not (generic-p method)) - (or (byte-code-function-p (symbol-function method)) - (not (eq 'autoload (car (symbol-function method))))) - ) - (error "You cannot create a generic/method over an existing symbol: %s" - method)) - ;; Don't do this over and over. - (unless (fboundp 'method) - ;; This defun tells emacs where the first definition of this - ;; method is defined. - `(defun ,method nil) - ;; Make sure the method tables are installed. - (eieiomt-install method) - ;; Apply the actual body of this function. - (fset method (eieio-defgeneric-form method doc-string)) - ;; Return the method - 'method)) -(make-obsolete 'eieio-defgeneric nil "24.1") +;; Hook ourselves into help system for describing classes and methods. +(add-hook 'help-fns-describe-function-functions 'eieio-help-generic) +(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) ;;; Interfacing with edebug ;; @@ -3080,14 +913,10 @@ Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." ) ) -;;; Autoloading some external symbols, and hooking into the help system -;; - ;;; Start of automatically extracted autoloads. -;;;### (autoloads (customize-object) "eieio-custom" "eieio-custom.el" -;;;;;; "928623502e8bf40454822355388542b5") +;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "5b0e7b1beea11f9e9de6887279f75d61") ;;; Generated autoloads from eieio-custom.el (autoload 'customize-object "eieio-custom" "\ @@ -3098,9 +927,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;*** -;;;### (autoloads (eieio-help-mode-augmentation-maybee eieio-describe-generic -;;;;;; eieio-describe-constructor eieio-describe-class eieio-browse) -;;;;;; "eieio-opt" "eieio-opt.el" "d808328f9c0156ecbd412d77ba8c569e") +;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "2be72f3dd71a50ab6e749c50e0353c62") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ @@ -3109,33 +936,22 @@ If optional ROOT-CLASS, then start with that, otherwise start with variable `eieio-default-superclass'. \(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. +(autoload 'eieio-help-class "eieio-opt" "\ +Print help description for CLASS. 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) +\(fn CLASS)" nil nil) -(autoload 'eieio-describe-generic "eieio-opt" "\ -Describe the generic function GENERIC. -Also extracts information about all methods specific to this generic. +(autoload 'eieio-help-constructor "eieio-opt" "\ +Describe CTR if it is a class constructor. -\(fn GENERIC)" t nil) +\(fn CTR)" nil nil) -(autoload 'eieio-help-mode-augmentation-maybee "eieio-opt" "\ -For buffers thrown into help mode, augment for EIEIO. -Arguments UNUSED are not used. +(autoload 'eieio-help-generic "eieio-opt" "\ +Describe GENERIC if it is a generic function. -\(fn &rest UNUSED)" nil nil) +\(fn GENERIC)" nil nil) ;;;*** diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 5a6b486dcd0..cedfd44dd1f 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -1,6 +1,6 @@ -;;; eldoc.el --- show function arglist or variable docstring in echo area +;;; eldoc.el --- show function arglist or variable docstring in echo area -*- lexical-binding: t; -*- -;; Copyright (C) 1996-2013 Free Software Foundation, Inc. +;; Copyright (C) 1996-2014 Free Software Foundation, Inc. ;; Author: Noah Friedman <friedman@splode.com> ;; Maintainer: friedman@splode.com @@ -36,9 +36,10 @@ ;; One useful way to enable this minor mode is to put the following in your ;; .emacs: ;; -;; (add-hook 'emacs-lisp-mode-hook 'turn-on-eldoc-mode) -;; (add-hook 'lisp-interaction-mode-hook 'turn-on-eldoc-mode) -;; (add-hook 'ielm-mode-hook 'turn-on-eldoc-mode) +;; (add-hook 'emacs-lisp-mode-hook 'eldoc-mode) +;; (add-hook 'lisp-interaction-mode-hook 'eldoc-mode) +;; (add-hook 'ielm-mode-hook 'eldoc-mode) +;; (add-hook 'eval-expression-minibuffer-setup-hook 'eldoc-mode) ;; Major modes for other languages may use ElDoc by defining an ;; appropriate function as the buffer-local value of @@ -62,6 +63,12 @@ If this variable is set to 0, no idle time is required." :type 'number :group 'eldoc) +(defcustom eldoc-print-after-edit nil + "If non-nil eldoc info is only shown when editing. +Changing the value requires toggling `eldoc-mode'." + :type 'boolean + :group 'eldoc) + ;;;###autoload (defcustom eldoc-minor-mode-string (purecopy " ElDoc") "String to display in mode line when ElDoc Mode is enabled; nil for none." @@ -146,6 +153,20 @@ directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.") "Idle time delay currently in use by timer. This is used to determine if `eldoc-idle-delay' is changed by the user.") +(defvar eldoc-message-function #'eldoc-minibuffer-message + "The function used by `eldoc-message' to display messages. +It should receive the same arguments as `message'.") + +(defun eldoc-edit-message-commands () + (let ((cmds (make-vector 31 0)) + (re (regexp-opt '("delete" "insert" "edit" "electric" "newline")))) + (mapatoms (lambda (s) + (and (commandp s) + (string-match-p re (symbol-name s)) + (intern (symbol-name s) cmds))) + obarray) + cmds)) + ;;;###autoload (define-minor-mode eldoc-mode @@ -164,30 +185,59 @@ expression point is on." (setq eldoc-last-message nil) (if eldoc-mode (progn + (when eldoc-print-after-edit + (setq-local eldoc-message-commands (eldoc-edit-message-commands))) (add-hook 'post-command-hook 'eldoc-schedule-timer nil t) - (add-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area t)) - (remove-hook 'post-command-hook 'eldoc-schedule-timer) - (remove-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area))) + (add-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area nil t)) + (kill-local-variable 'eldoc-message-commands) + (remove-hook 'post-command-hook 'eldoc-schedule-timer t) + (remove-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area t))) ;;;###autoload -(defun turn-on-eldoc-mode () - "Unequivocally turn on ElDoc mode (see command `eldoc-mode')." - (interactive) - (eldoc-mode 1)) +(define-obsolete-function-alias 'turn-on-eldoc-mode 'eldoc-mode "24.4") (defun eldoc-schedule-timer () (or (and eldoc-timer (memq eldoc-timer timer-idle-list)) (setq eldoc-timer - (run-with-idle-timer eldoc-idle-delay t - 'eldoc-print-current-symbol-info))) + (run-with-idle-timer + eldoc-idle-delay t + (lambda () (and eldoc-mode (eldoc-print-current-symbol-info)))))) ;; If user has changed the idle delay, update the timer. (cond ((not (= eldoc-idle-delay eldoc-current-idle-delay)) (setq eldoc-current-idle-delay eldoc-idle-delay) (timer-set-idle-time eldoc-timer eldoc-idle-delay t)))) +(defvar eldoc-mode-line-string nil) +(put 'eldoc-mode-line-string 'risky-local-variable t) + +(defun eldoc-minibuffer-message (format-string &rest args) + "Display messages in the mode-line when in the minibuffer. +Otherwise work like `message'." + (if (minibufferp) + (progn + (add-hook 'minibuffer-exit-hook + (lambda () (setq eldoc-mode-line-string nil)) + nil t) + (with-current-buffer + (window-buffer + (or (window-in-direction 'above (minibuffer-window)) + (minibuffer-selected-window) + (get-largest-window))) + (unless (and (listp mode-line-format) + (assq 'eldoc-mode-line-string mode-line-format)) + (setq mode-line-format + (list "" '(eldoc-mode-line-string + (" " eldoc-mode-line-string " ")) + mode-line-format))) + (setq eldoc-mode-line-string + (when (stringp format-string) + (apply 'format format-string args))) + (force-mode-line-update))) + (apply 'message format-string args))) + (defun eldoc-message (&rest args) (let ((omessage eldoc-last-message)) (setq eldoc-last-message @@ -203,10 +253,15 @@ expression point is on." ;; they are Legion. ;; Emacs way of preventing log messages. (let ((message-log-max nil)) - (cond (eldoc-last-message (message "%s" eldoc-last-message)) - (omessage (message nil))))) + (cond (eldoc-last-message + (funcall eldoc-message-function "%s" eldoc-last-message)) + (omessage (funcall eldoc-message-function nil))))) eldoc-last-message) +(defun eldoc--message-command-p (command) + (and (symbolp command) + (intern-soft (symbol-name command) eldoc-message-commands))) + ;; This function goes on pre-command-hook for XEmacs or when using idle ;; timers in Emacs. Motion commands clear the echo area for some reason, ;; which make eldoc messages flicker or disappear just before motion @@ -215,8 +270,12 @@ expression point is on." ;; This doesn't seem to be required for Emacs 19.28 and earlier. (defun eldoc-pre-command-refresh-echo-area () (and eldoc-last-message - (if (eldoc-display-message-no-interference-p) - (eldoc-message eldoc-last-message) + (not (minibufferp)) ;We don't use the echo area when in minibuffer. + (if (and (eldoc-display-message-no-interference-p) + (eldoc--message-command-p this-command)) + (eldoc-message eldoc-last-message) + ;; No need to call eldoc-message since the echo area will be cleared + ;; for us, but do note that the last-message will be gone. (setq eldoc-last-message nil)))) ;; Decide whether now is a good time to display a message. @@ -226,21 +285,14 @@ expression point is on." ;; timer, we're still in the middle of executing a command, ;; e.g. a query-replace where it would be annoying to ;; overwrite the echo area. - (and (not this-command) - (symbolp last-command) - (intern-soft (symbol-name last-command) - eldoc-message-commands)))) + (not this-command) + (eldoc--message-command-p last-command))) + ;; Check various conditions about the current environment that might make ;; it undesirable to print eldoc messages right this instant. (defun eldoc-display-message-no-interference-p () - (and eldoc-mode - (not executing-kbd-macro) - (not (and (boundp 'edebug-active) edebug-active)) - ;; Having this mode operate in an active minibuffer/echo area causes - ;; interference with what's going on there. - (not cursor-in-echo-area) - (not (eq (selected-window) (minibuffer-window))))) + (not (or executing-kbd-macro (bound-and-true-p edebug-active)))) ;;;###autoload @@ -261,27 +313,30 @@ This variable is expected to be made buffer-local by modes (other than Emacs Lisp mode) that support ElDoc.") (defun eldoc-print-current-symbol-info () - (condition-case err - (and (eldoc-display-message-p) - (if eldoc-documentation-function - (eldoc-message (funcall eldoc-documentation-function)) - (let* ((current-symbol (eldoc-current-symbol)) - (current-fnsym (eldoc-fnsym-in-current-sexp)) - (doc (cond - ((null current-fnsym) - nil) - ((eq current-symbol (car current-fnsym)) - (or (apply 'eldoc-get-fnsym-args-string - current-fnsym) - (eldoc-get-var-docstring current-symbol))) - (t - (or (eldoc-get-var-docstring current-symbol) - (apply 'eldoc-get-fnsym-args-string - current-fnsym)))))) - (eldoc-message doc)))) - ;; This is run from post-command-hook or some idle timer thing, - ;; so we need to be careful that errors aren't ignored. - (error (message "eldoc error: %s" err)))) + ;; This is run from post-command-hook or some idle timer thing, + ;; so we need to be careful that errors aren't ignored. + (with-demoted-errors "eldoc error: %s" + (and (or (eldoc-display-message-p) + ;; Erase the last message if we won't display a new one. + (when eldoc-last-message + (eldoc-message nil) + nil)) + (if eldoc-documentation-function + (eldoc-message (funcall eldoc-documentation-function)) + (let* ((current-symbol (eldoc-current-symbol)) + (current-fnsym (eldoc-fnsym-in-current-sexp)) + (doc (cond + ((null current-fnsym) + nil) + ((eq current-symbol (car current-fnsym)) + (or (apply 'eldoc-get-fnsym-args-string + current-fnsym) + (eldoc-get-var-docstring current-symbol))) + (t + (or (eldoc-get-var-docstring current-symbol) + (apply 'eldoc-get-fnsym-args-string + current-fnsym)))))) + (eldoc-message doc)))))) (defun eldoc-get-fnsym-args-string (sym &optional index) "Return a string containing the parameter list of the function SYM. @@ -440,11 +495,11 @@ In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." (defun eldoc-beginning-of-sexp () (let ((parse-sexp-ignore-comments t) (num-skipped-sexps 0)) - (condition-case err + (condition-case _ (progn ;; First account for the case the point is directly over a ;; beginning of a nested sexp. - (condition-case err + (condition-case _ (let ((p (point))) (forward-sexp -1) (forward-sexp 1) @@ -468,10 +523,9 @@ In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." ;; Do indirect function resolution if possible. (defun eldoc-symbol-function (fsym) - (let ((defn (and (fboundp fsym) - (symbol-function fsym)))) + (let ((defn (symbol-function fsym))) (and (symbolp defn) - (condition-case err + (condition-case _ (setq defn (indirect-function fsym)) (error (setq defn nil)))) defn)) diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 7998f732f06..77da42450e9 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -1,6 +1,6 @@ ;;; elint.el --- Lint Emacs Lisp -;; Copyright (C) 1997, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1997, 2001-2014 Free Software Foundation, Inc. ;; Author: Peter Liljenberg <petli@lysator.liu.se> ;; Created: May 1997 @@ -1145,8 +1145,8 @@ Marks the function with their arguments, and returns a list of variables." (defun elint-find-builtins () "Return a list of all built-in functions." (let (subrs) - (mapatoms (lambda (s) (and (fboundp s) (subrp (symbol-function s)) - (setq subrs (cons s subrs))))) + (mapatoms (lambda (s) (and (subrp (symbol-function s)) + (push s subrs)))) subrs)) (defun elint-find-builtin-args (&optional list) diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index f1321eb4e6d..c7a564074cb 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -1,10 +1,10 @@ ;;; elp.el --- Emacs Lisp Profiler -*- lexical-binding: t -*- -;; Copyright (C) 1994-1995, 1997-1998, 2001-2013 Free Software +;; Copyright (C) 1994-1995, 1997-1998, 2001-2014 Free Software ;; Foundation, Inc. ;; Author: Barry A. Warsaw -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Created: 26-Feb-1994 ;; Keywords: debugging lisp tools @@ -251,7 +251,7 @@ FUNSYM must be a symbol of a defined function." ;; Set the symbol's new profiling function definition to run ;; ELP wrapper. (advice-add funsym :around (elp--make-wrapper funsym) - `((name . ,elp--advice-name))))) + `((name . ,elp--advice-name) (depth . -99))))) (defun elp--instrumented-p (sym) (advice-member-p elp--advice-name sym)) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 531e83c1e6a..726856c6fd1 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -1,6 +1,6 @@ ;;; ert-x.el --- Staging area for experimental extensions to ERT -*- lexical-binding: t -*- -;; Copyright (C) 2008, 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. ;; Author: Lennart Borgman (lennart O borgman A gmail O com) ;; Christian Ohler <ohler@gnu.org> diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 7df3acccbc9..ee058a8f607 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1,6 +1,6 @@ ;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*- -;; Copyright (C) 2007-2008, 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2008, 2010-2014 Free Software Foundation, Inc. ;; Author: Christian Ohler <ohler@gnu.org> ;; Keywords: lisp, tools @@ -34,14 +34,17 @@ ;; `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. +;; additional operators `should', `should-not', `should-error' and +;; `skip-unless' 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. `skip-unless' skips the test immediately without +;; processing further, this is useful for checking the test +;; environment (like availability of features, external binaries, etc). ;; ;; See ERT's info manual as well as the docstrings for more details. ;; To compile the manual, run `makeinfo ert.texinfo' in the ERT @@ -54,7 +57,7 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (require 'button) (require 'debug) (require 'easymenu) @@ -87,127 +90,6 @@ ;;; 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." - (cl-loop for ert-x in ert-list - if (funcall ert-pred ert-x) - collect ert-x)) - -(defun ert--intersection (a b) - "A reimplementation of `intersection'. Intersect the sets A and B. - -Elements are compared using `eql'." - (cl-loop for x in a - if (memql x b) - collect x)) - -(defun ert--set-difference (a b) - "A reimplementation of `set-difference'. Subtract the set B from the set A. - -Elements are compared using `eql'." - (cl-loop for x in a - unless (memql x b) - collect x)) - -(defun ert--set-difference-eq (a b) - "A reimplementation of `set-difference'. Subtract the set B from the set A. - -Elements are compared using `eq'." - (cl-loop for x in a - unless (memq x b) - collect x)) - -(defun ert--union (a b) - "A reimplementation of `union'. Compute the union of the sets A and B. - -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 - (cl-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))) - -(cl-defun ert--remove* (x list &key key test) - "Does not support all the keywords of remove*." - (unless key (setq key #'identity)) - (unless test (setq test #'eql)) - (cl-loop for y in list - unless (funcall test x (funcall key y)) - collect y)) - -(defun ert--string-position (c s) - "Return the position of the first occurrence of C in S, or nil if none." - (cl-loop for i from 0 - for x across s - when (eql x c) return i)) - -(defun ert--mismatch (a b) - "Return index of first element that differs between A and B. - -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))) - (cl-assert (arrayp a) t) - (cl-assert (arrayp b) t) - (cl-assert (<= la lb) t) - (cl-loop for i below la - when (not (equal (aref a i) (aref b i))) return i - finally (cl-return (if (/= la lb) - la - (cl-assert (equal a b) t) - nil))))))) - -(defun ert--subseq (seq start &optional end) - "Return a subsequence of SEQ from START to END." - (when (char-table-p seq) (error "Not supported")) - (let ((vector (substring (ert--coerce-to-vector seq) start end))) - (cl-etypecase seq - (vector vector) - (string (concat vector)) - (list (append vector nil)) - (bool-vector (cl-loop with result - = (make-bool-vector (length vector) nil) - for i below (length vector) do - (setf (aref result i) (aref vector i)) - finally (cl-return result))) - (char-table (cl-assert nil))))) - (defun ert-equal-including-properties (a b) "Return t if A and B have similar structure and contents. @@ -258,7 +140,7 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." (defun ert-make-test-unbound (symbol) "Make SYMBOL name no test. Return SYMBOL." - (ert--remprop symbol 'ert--test) + (cl-remprop symbol 'ert--test) symbol) (defun ert--parse-keys-and-body (keys-and-body) @@ -295,8 +177,8 @@ and the body." 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. +`should', `should-not', `should-error' and `skip-unless' are +useful for assertions in BODY. Use `ert' to run tests interactively. @@ -321,7 +203,7 @@ description of valid values for RESULT-TYPE. (tags nil tags-supplied-p)) body) (ert--parse-keys-and-body docstring-keys-and-body) - `(progn + `(cl-macrolet ((skip-unless (form) `(ert--skip-unless ,form))) (ert-set-test ',name (make-ert-test :name ',name @@ -357,8 +239,8 @@ description of valid values for RESULT-TYPE. "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") +(define-error 'ert-test-failed "Test failed") +(define-error 'ert-test-skipped "Test skipped") (defun ert-pass () "Terminate the current test and mark it passed. Does not return." @@ -369,6 +251,11 @@ description of valid values for RESULT-TYPE. DATA is displayed to the user and should state the reason of the failure." (signal 'ert-test-failed (list data))) +(defun ert-skip (data) + "Terminate the current test and mark it skipped. Does not return. +DATA is displayed to the user and should state the reason for skipping." + (signal 'ert-test-skipped (list data))) + ;;; The `should' macros. @@ -396,8 +283,8 @@ DATA is displayed to the user and should state the reason of the failure." 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-"))) + (let ((value (cl-gensym "value-"))) + `(let ((,value (cl-gensym "ert-form-evaluation-aborted-"))) ,(funcall inner-expander `(setq ,value ,form) `(list ',whole :form ',form :value ,value) @@ -410,10 +297,10 @@ DATA is displayed to the user and should state the reason of the failure." (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 (cl-gensym "fn-")) + (args (cl-gensym "args-")) + (value (cl-gensym "value-")) + (default-value (cl-gensym "ert-form-evaluation-aborted-"))) `(let ((,fn (function ,fn-name)) (,args (list ,@arg-forms))) (let ((,value ',default-value)) @@ -450,7 +337,7 @@ FORM-DESCRIPTION-FORM before it has called INNER-FORM." (ert--expand-should-1 whole form (lambda (inner-form form-description-form value-var) - (let ((form-description (ert--gensym "form-description-"))) + (let ((form-description (cl-gensym "form-description-"))) `(let (,form-description) ,(funcall inner-expander `(unwind-protect @@ -464,6 +351,7 @@ FORM-DESCRIPTION-FORM before it has called INNER-FORM." "Evaluate FORM. If it returns nil, abort the current test as failed. Returns the value of FORM." + (declare (debug t)) (ert--expand-should `(should ,form) form (lambda (inner-form form-description-form _value-var) `(unless ,inner-form @@ -473,6 +361,7 @@ Returns the value of FORM." "Evaluate FORM. If it returns non-nil, abort the current test as failed. Returns nil." + (declare (debug t)) (ert--expand-should `(should-not ,form) form (lambda (inner-form form-description-form _value-var) `(unless (not ,inner-form) @@ -489,7 +378,7 @@ and aborts the current test as failed if it doesn't." (list type) (symbol (list type))))) (cl-assert signaled-conditions) - (unless (ert--intersection signaled-conditions handled-conditions) + (unless (cl-intersection signaled-conditions handled-conditions) (ert-fail (append (funcall form-description-fn) (list @@ -520,13 +409,14 @@ non-nil, the error matches TYPE if it is an element of TYPE. If the error matches, returns (ERROR-SYMBOL . DATA) from the error. If not, or if no error was signaled, abort the test as failed." + (declare (debug t)) (unless type (setq type ''error)) (ert--expand-should `(should-error ,form ,@keys) form (lambda (inner-form form-description-form value-var) - (let ((errorp (ert--gensym "errorp")) - (form-description-fn (ert--gensym "form-description-fn-"))) + (let ((errorp (cl-gensym "errorp")) + (form-description-fn (cl-gensym "form-description-fn-"))) `(let ((,errorp nil) (,form-description-fn (lambda () ,form-description-form))) (condition-case -condition- @@ -544,6 +434,15 @@ failed." (list :fail-reason "did not signal an error"))))))))) +(cl-defmacro ert--skip-unless (form) + "Evaluate FORM. If it returns nil, skip the current test. +Errors during evaluation are caught and handled like nil." + (declare (debug t)) + (ert--expand-should `(skip-unless ,form) form + (lambda (inner-form form-description-form _value-var) + `(unless (ignore-errors ,inner-form) + (ert-skip ,form-description-form))))) + ;;; Explanation of `should' failures. @@ -588,7 +487,7 @@ Returns nil if they are." `(proper-lists-of-different-length ,(length a) ,(length b) ,a ,b first-mismatch-at - ,(ert--mismatch a b)) + ,(cl-mismatch a b :test 'equal)) (cl-loop for i from 0 for ai in a for bi in b @@ -608,7 +507,7 @@ Returns nil if they are." ,a ,b ,@(unless (char-table-p a) `(first-mismatch-at - ,(ert--mismatch a b)))) + ,(cl-mismatch a b :test 'equal)))) (cl-loop for i from 0 for ai across a for bi across b @@ -653,8 +552,8 @@ key/value pairs in each list does not matter." ;; 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))) + (keys-in-a-not-in-b (cl-set-difference keys-a keys-b :test 'eq)) + (keys-in-b-not-in-a (cl-set-difference keys-b keys-a :test 'eq))) (cl-flet ((explain-with-key (key) (let ((value-a (plist-get a key)) (value-b (plist-get b key))) @@ -763,6 +662,7 @@ and is displayed in front of the value of MESSAGE-FORM." (infos (cl-assert nil))) (cl-defstruct (ert-test-quit (:include ert-test-result-with-condition))) (cl-defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(cl-defstruct (ert-test-skipped (:include ert-test-result-with-condition))) (cl-defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) @@ -847,6 +747,7 @@ run. ARGS are the arguments to `debugger'." (let* ((condition (car more-debugger-args)) (type (cl-case (car condition) ((quit) 'quit) + ((ert-test-skipped) 'skipped) (otherwise 'failed))) (backtrace (ert--record-backtrace)) (infos (reverse ert--infos))) @@ -856,6 +757,10 @@ run. ARGS are the arguments to `debugger'." (make-ert-test-quit :condition condition :backtrace backtrace :infos infos)) + (skipped + (make-ert-test-skipped :condition condition + :backtrace backtrace + :infos infos)) (failed (make-ert-test-failed :condition condition :backtrace backtrace @@ -904,7 +809,7 @@ This mainly sets up debugger-related bindings." "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*") + (with-current-buffer (messages-buffer) ;; This is a reimplementation of this part of message_dolog() in xdisp.c: ;; if (NATNUMP (Vmessage_log_max)) ;; { @@ -917,7 +822,8 @@ This can be useful after reducing the value of `message-log-max'." (end (save-excursion (goto-char (point-max)) (forward-line (- message-log-max)) - (point)))) + (point))) + (inhibit-read-only t)) (delete-region begin end))))) (defvar ert--running-tests nil @@ -937,7 +843,7 @@ Returns the result and stores it in ERT-TEST's `most-recent-result' slot." (setf (ert-test-most-recent-result ert-test) nil) (cl-block error (let ((begin-marker - (with-current-buffer (get-buffer-create "*Messages*") + (with-current-buffer (messages-buffer) (point-max-marker)))) (unwind-protect (let ((info (make-ert--test-execution-info @@ -956,7 +862,7 @@ Returns the result and stores it in ERT-TEST's `most-recent-result' slot." (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*") + (with-current-buffer (messages-buffer) (buffer-substring begin-marker (point-max)))) (ert--force-message-log-buffer-truncation) (setq should-form-accu (nreverse should-form-accu)) @@ -980,7 +886,7 @@ Valid result types: nil -- Never matches. t -- Always matches. -:failed, :passed -- Matches corresponding results. +:failed, :passed, :skipped -- 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. @@ -993,6 +899,7 @@ t -- Always matches. ((member t) t) ((member :failed) (ert-test-failed-p result)) ((member :passed) (ert-test-passed-p result)) + ((member :skipped) (ert-test-skipped-p result)) (cons (cl-destructuring-bind (operator &rest operands) result-type (cl-ecase operator @@ -1017,7 +924,9 @@ t -- Always matches. (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))) + (or + (ert-test-result-type-p result :skipped) + (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. @@ -1087,10 +996,11 @@ contained in UNIVERSE." (cl-etypecase universe ((member t) (mapcar #'ert-get-test (apropos-internal selector #'ert-test-boundp))) - (list (ert--remove-if-not (lambda (test) + (list (cl-remove-if-not (lambda (test) (and (ert-test-name test) (string-match selector - (ert-test-name test)))) + (symbol-name + (ert-test-name test))))) universe)))) (ert-test (list selector)) (symbol @@ -1120,13 +1030,13 @@ contained in UNIVERSE." (not (cl-assert (eql (length operands) 1)) (let ((all-tests (ert-select-tests 't universe))) - (ert--set-difference all-tests + (cl-set-difference all-tests (ert-select-tests (car operands) all-tests)))) (or (cl-case (length operands) (0 (ert-select-tests 'nil universe)) - (t (ert--union (ert-select-tests (car operands) universe) + (t (cl-union (ert-select-tests (car operands) universe) (ert-select-tests `(or ,@(cdr operands)) universe))))) (tag @@ -1138,7 +1048,7 @@ contained in UNIVERSE." universe))) (satisfies (cl-assert (eql (length operands) 1)) - (ert--remove-if-not (car operands) + (cl-remove-if-not (car operands) (ert-select-tests 't universe)))))))) (defun ert--insert-human-readable-selector (selector) @@ -1203,6 +1113,7 @@ contained in UNIVERSE." (passed-unexpected 0) (failed-expected 0) (failed-unexpected 0) + (skipped 0) (start-time nil) (end-time nil) (aborted-p nil) @@ -1221,10 +1132,15 @@ contained in UNIVERSE." (+ (ert--stats-passed-unexpected stats) (ert--stats-failed-unexpected stats))) +(defun ert-stats-skipped (stats) + "Number of tests in STATS that have skipped." + (ert--stats-skipped 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))) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats))) (defun ert-stats-total (stats) "Number of tests in STATS, regardless of whether they have run yet." @@ -1256,6 +1172,8 @@ Also changes the counters in STATS to match." (cl-incf (ert--stats-passed-expected stats) d)) (ert-test-failed (cl-incf (ert--stats-failed-expected stats) d)) + (ert-test-skipped + (cl-incf (ert--stats-skipped stats) d)) (null) (ert-test-aborted-with-non-local-exit) (ert-test-quit)) @@ -1264,6 +1182,8 @@ Also changes the counters in STATS to match." (cl-incf (ert--stats-passed-unexpected stats) d)) (ert-test-failed (cl-incf (ert--stats-failed-unexpected stats) d)) + (ert-test-skipped + (cl-incf (ert--stats-skipped stats) d)) (null) (ert-test-aborted-with-non-local-exit) (ert-test-quit))))) @@ -1282,7 +1202,7 @@ Also changes the counters in STATS to match." "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)) + (setq tests (cl-coerce tests 'vector)) (let ((map (make-hash-table :size (length tests)))) (cl-loop for i from 0 for test across tests @@ -1358,6 +1278,7 @@ EXPECTEDP specifies whether the result was expected." (let ((s (cl-etypecase result (ert-test-passed ".P") (ert-test-failed "fF") + (ert-test-skipped "sS") (null "--") (ert-test-aborted-with-non-local-exit "aA") (ert-test-quit "qQ")))) @@ -1370,6 +1291,7 @@ EXPECTEDP specifies whether the result was expected." (let ((s (cl-etypecase result (ert-test-passed '("passed" "PASSED")) (ert-test-failed '("failed" "FAILED")) + (ert-test-skipped '("skipped" "SKIPPED")) (null '("unknown" "UNKNOWN")) (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")) (ert-test-quit '("quit" "QUIT"))))) @@ -1436,8 +1358,9 @@ Returns the stats object." (run-ended (cl-destructuring-bind (stats abortedp) event-args (let ((unexpected (ert-stats-completed-unexpected stats)) - (expected-failures (ert--stats-failed-expected stats))) - (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" + (skipped (ert-stats-skipped stats)) + (expected-failures (ert--stats-failed-expected stats))) + (message "\n%sRan %s tests, %s results as expected%s%s (%s)%s\n" (if (not abortedp) "" "Aborted: ") @@ -1446,6 +1369,9 @@ Returns the stats object." (if (zerop unexpected) "" (format ", %s unexpected" unexpected)) + (if (zerop skipped) + "" + (format ", %s skipped" skipped)) (ert--format-time-iso8601 (ert--stats-end-time stats)) (if (zerop expected-failures) "" @@ -1458,6 +1384,15 @@ Returns the stats object." (message "%9s %S" (ert-string-for-test-result result nil) (ert-test-name test)))) + (message "%s" "")) + (unless (zerop skipped) + (message "%s skipped results:" skipped) + (cl-loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (ert-test-result-type-p result :skipped) + (message "%9s %S" + (ert-string-for-test-result result nil) + (ert-test-name test)))) (message "%s" ""))))) (test-started ) @@ -1534,7 +1469,7 @@ the tests)." "Activate font-lock keywords for some of ERT's symbols." (font-lock-add-keywords nil - '(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\sw+\\)?" + '(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\(?:\\sw\\|\\s_\\)+\\)?" (1 font-lock-keyword-face nil t) (2 font-lock-function-name-face nil t))))) @@ -1545,10 +1480,10 @@ 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))) + (cl-remove element + (symbol-value list-var) + :key key + :test test))) ;;; Some basic interactive functions. @@ -1680,15 +1615,17 @@ Also sets `ert--results-progress-bar-button-begin'." (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") + (format (concat "Passed: %s\n" + "Failed: %s\n" + "Skipped: %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)) + (ert-stats-skipped stats) run-count (ert-stats-total stats))) (insert @@ -1807,7 +1744,7 @@ BEGIN and END specify a region in the current buffer." "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))) + (substring s 0 (cl-position ?\n s))) (defun ert-face-for-test-result (expectedp) "Return a face that shows whether a test result was expected or unexpected. @@ -1945,11 +1882,11 @@ and how to display message." ;; 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)) + (completing-read (if (null default) + "Run tests: " + (format "Run tests (default %s): " default)) + obarray #'ert-test-boundp nil nil + 'ert--selector-history default nil)) nil)) (unless message-fn (setq message-fn 'message)) (let ((output-buffer-name output-buffer-name) @@ -1968,7 +1905,7 @@ and how to display message." (run-ended (cl-destructuring-bind (stats abortedp) event-args (funcall message-fn - "%sRan %s tests, %s results were as expected%s" + "%sRan %s tests, %s results were as expected%s%s" (if (not abortedp) "" "Aborted: ") @@ -1978,7 +1915,12 @@ and how to display message." (ert-stats-completed-unexpected stats))) (if (zerop unexpected) "" - (format ", %s unexpected" unexpected)))) + (format ", %s unexpected" unexpected))) + (let ((skipped + (ert-stats-skipped stats))) + (if (zerop skipped) + "" + (format ", %s skipped" skipped)))) (ert--results-update-stats-display (with-current-buffer buffer ert--results-ewoc) stats))) diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index ffd17e5d7af..2ba1ca9c6b0 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -1,6 +1,6 @@ ;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer -*- lexical-binding: t -*- -;; Copyright (C) 1991-2013 Free Software Foundation, Inc. +;; Copyright (C) 1991-2014 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> ;; Inge Wallin <inge@lysator.liu.se> diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index f06ad912bc8..5c404ce0468 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -1,6 +1,6 @@ ;;; find-func.el --- find the definition of the Emacs Lisp function near point -;; Copyright (C) 1997, 1999, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2014 Free Software Foundation, Inc. ;; Author: Jens Petersen <petersen@kurims.kyoto-u.ac.jp> ;; Maintainer: petersen@kurims.kyoto-u.ac.jp @@ -219,7 +219,7 @@ TYPE should be nil to find a function, or `defvar' to find a variable." (regexp-quote (symbol-name fun-or-var)) "\"") (concat "DEFUN[ \t\n]*([ \t\n]*\"" - (regexp-quote (subr-name fun-or-var)) + (regexp-quote (subr-name (advice--cd*r fun-or-var))) "\"")) nil t) (error "Can't find source for %s" fun-or-var)) diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el index 82b3e94bb4d..ff9062150db 100644 --- a/lisp/emacs-lisp/find-gc.el +++ b/lisp/emacs-lisp/find-gc.el @@ -1,8 +1,8 @@ ;;; find-gc.el --- detect functions that call the garbage collector -;; Copyright (C) 1992, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2014 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index 6dee2cb48da..30523c5d675 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -1,8 +1,8 @@ ;;; float-sup.el --- define some constants useful for floating point numbers. -;; Copyright (C) 1985-1987, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1985-1987, 2001-2014 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal ;; Package: emacs diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index dd5ff0ec694..02c30aad55f 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -1,6 +1,6 @@ ;;; generic.el --- defining simple major modes with comment and font-lock ;; -;; Copyright (C) 1997, 1999, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2014 Free Software Foundation, Inc. ;; ;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Fri Sep 27 1996 @@ -44,11 +44,8 @@ ;; end at the end of the line.) Emacs does not support comment ;; strings of more than two characters in length. ;; -;; * List of keywords to font-lock. Each keyword should be a string. -;; If you have additional keywords which should be highlighted in a -;; face different from `font-lock-keyword-face', you can use the -;; convenience function `generic-make-keywords-list' (which see), -;; and add the result to the following list: +;; * List of keywords to font-lock in `font-lock-keyword-face'. +;; Each keyword should be a string. ;; ;; * Additional expressions to font-lock. This should be a list of ;; expressions, each of which should be of the same form as those in @@ -93,6 +90,8 @@ ;;; Code: +(eval-when-compile (require 'pcase)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal Variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -224,18 +223,11 @@ Some generic modes are defined in `generic-x.el'." (funcall (intern mode))) ;;; Comment Functionality -(defun generic-mode-set-comments (comment-list) - "Set up comment functionality for generic mode." - (let ((st (make-syntax-table)) - (chars nil) - (comstyles)) - (make-local-variable 'comment-start) - (make-local-variable 'comment-start-skip) - (make-local-variable 'comment-end) - ;; Go through all the comments +(defun generic--normalize-comments (comment-list) + (let ((normalized '())) (dolist (start comment-list) - (let (end (comstyle "")) + (let (end) ;; Normalize (when (consp start) (setq end (cdr start)) @@ -244,58 +236,79 @@ Some generic modes are defined in `generic-x.el'." (cond ((characterp end) (setq end (char-to-string end))) ((zerop (length end)) (setq end "\n"))) + (push (cons start end) normalized))) + (nreverse normalized))) - ;; Setup the vars for `comment-region' - (if comment-start - ;; We have already setup a comment-style, so use style b - (progn - (setq comstyle "b") - (setq comment-start-skip - (concat comment-start-skip "\\|" (regexp-quote start) "+\\s-*"))) - ;; First comment-style - (setq comment-start start) - (setq comment-end (if (string-equal end "\n") "" end)) - (setq comment-start-skip (concat (regexp-quote start) "+\\s-*"))) - - ;; Reuse comstyles if necessary - (setq comstyle +(defun generic-set-comment-syntax (st comment-list) + "Set up comment functionality for generic mode." + (let ((chars nil) + (comstyles) + (comstyle "") + (comment-start nil)) + + ;; Go through all the comments. + (pcase-dolist (`(,start . ,end) comment-list) + (let ((comstyle + ;; Reuse comstyles if necessary. (or (cdr (assoc start comstyles)) (cdr (assoc end comstyles)) - comstyle)) + ;; Otherwise, use a style not yet in use. + (if (not (rassoc "" comstyles)) "") + (if (not (rassoc "b" comstyles)) "b") + "c"))) (push (cons start comstyle) comstyles) (push (cons end comstyle) comstyles) - ;; Setup the syntax table + ;; Setup the syntax table. (if (= (length start) 1) - (modify-syntax-entry (string-to-char start) + (modify-syntax-entry (aref start 0) (concat "< " comstyle) st) - (let ((c0 (elt start 0)) (c1 (elt start 1))) - ;; Store the relevant info but don't update yet + (let ((c0 (aref start 0)) (c1 (aref start 1))) + ;; Store the relevant info but don't update yet. (push (cons c0 (concat (cdr (assoc c0 chars)) "1")) chars) (push (cons c1 (concat (cdr (assoc c1 chars)) (concat "2" comstyle))) chars))) (if (= (length end) 1) - (modify-syntax-entry (string-to-char end) + (modify-syntax-entry (aref end 0) (concat ">" comstyle) st) - (let ((c0 (elt end 0)) (c1 (elt end 1))) - ;; Store the relevant info but don't update yet + (let ((c0 (aref end 0)) (c1 (aref end 1))) + ;; Store the relevant info but don't update yet. (push (cons c0 (concat (cdr (assoc c0 chars)) (concat "3" comstyle))) chars) (push (cons c1 (concat (cdr (assoc c1 chars)) "4")) chars))))) ;; Process the chars that were part of a 2-char comment marker + (with-syntax-table st ;For `char-syntax'. (dolist (cs (nreverse chars)) (modify-syntax-entry (car cs) (concat (char-to-string (char-syntax (car cs))) " " (cdr cs)) - st)) + st))))) + +(defun generic-set-comment-vars (comment-list) + (when comment-list + (setq-local comment-start (caar comment-list)) + (setq-local comment-end + (let ((end (cdar comment-list))) + (if (string-equal end "\n") "" end))) + (setq-local comment-start-skip + (concat (regexp-opt (mapcar #'car comment-list)) + "+[ \t]*")) + (setq-local comment-end-skip + (concat "[ \t]*" (regexp-opt (mapcar #'cdr comment-list)))))) + +(defun generic-mode-set-comments (comment-list) + "Set up comment functionality for generic mode." + (let ((st (make-syntax-table)) + (comment-list (generic--normalize-comments comment-list))) + (generic-set-comment-syntax st comment-list) + (generic-set-comment-vars comment-list) (set-syntax-table st))) (defun generic-bracket-support () "Imenu support for [KEYWORD] constructs found in INF, INI and Samba files." - (setq imenu-generic-expression - '((nil "^\\[\\(.*\\)\\]" 1)) - imenu-case-fold-search t)) + (setq-local imenu-generic-expression '((nil "^\\[\\(.*\\)\\]" 1))) + (setq-local imenu-case-fold-search t)) ;;;###autoload (defun generic-make-keywords-list (keyword-list face &optional prefix suffix) @@ -306,6 +319,7 @@ expression that matches these keywords and concatenates it with PREFIX and SUFFIX. Then it returns a construct based on this regular expression that can be used as an element of `font-lock-keywords'." + (declare (obsolete regexp-opt "24.4")) (unless (listp keyword-list) (error "Keywords argument must be a list of strings")) (list (concat prefix "\\_<" diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el index d3a43329366..d0a89b3075a 100644 --- a/lisp/emacs-lisp/gulp.el +++ b/lisp/emacs-lisp/gulp.el @@ -1,9 +1,9 @@ ;;; gulp.el --- ask for updates for Lisp packages -;; Copyright (C) 1996, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1996, 2001-2014 Free Software Foundation, Inc. ;; Author: Sam Shteingold <shteingd@math.ucla.edu> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: maint ;; This file is part of GNU Emacs. @@ -33,8 +33,9 @@ :prefix "-" :group 'maint) -(defcustom gulp-discard "^;+ *Maintainer: *FSF *$" +(defcustom gulp-discard "^;+ *Maintainer: *\\(FSF\\|emacs-devel@gnu\\.org\\) *$" "The regexp matching the packages not requiring the request for updates." + :version "24.4" ; added emacs-devel :type 'regexp :group 'gulp) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index cf090e5e758..66241897536 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -1,6 +1,6 @@ ;;; gv.el --- generalized variables -*- lexical-binding: t -*- -;; Copyright (C) 2012-2013 Free Software Foundation, Inc. +;; Copyright (C) 2012-2014 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions @@ -102,7 +102,9 @@ DO must return an Elisp expression." ;; Follow aliases. (setq me (cons (symbol-function head) (cdr place)))) (if (eq me place) - (error "%S is not a valid place expression" place) + (if (and (symbolp head) (get head 'setf-method)) + (error "Incompatible place needs recompilation: %S" head) + (error "%S is not a valid place expression" place)) (gv-get me do))))))) ;;;###autoload @@ -155,11 +157,13 @@ arguments as NAME. DO is a function as defined in `gv-get'." (_ (message "Unknown %s declaration %S" symbol handler) nil)))) ;;;###autoload -(push `(gv-expander ,(apply-partially #'gv--defun-declaration 'gv-expander)) - defun-declarations-alist) +(or (assq 'gv-expander defun-declarations-alist) + (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) +(or (assq 'gv-setter defun-declarations-alist) + (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. @@ -217,13 +221,15 @@ instead the assignment is turned into something equivalent to temp) so as to preserve the semantics of `setf'." (declare (debug (sexp (&or symbolp lambda-expr) &optional sexp))) + (when (eq 'lambda (car-safe setter)) + (message "Use `gv-define-setter' or name %s's setter function" name)) `(gv-define-setter ,name (val &rest args) ,(if fix-return `(macroexp-let2 nil v val `(progn - (,',setter ,@(append args (list v))) + (,',setter ,@args ,v) ,v)) - `(cons ',setter (append args (list val)))))) + ``(,',setter ,@args ,val)))) ;;; Typical operations on generalized variables. @@ -342,6 +348,10 @@ The return value is the last VAL in the list. (gv-define-simple-setter window-point set-window-point) (gv-define-simple-setter window-start set-window-start) +(gv-define-setter buffer-local-value (val var buf) + (macroexp-let2 nil v val + `(with-current-buffer ,buf (set (make-local-variable ,var) ,v)))) + ;;; Some occasionally handy extensions. ;; While several of the "places" below are not terribly useful for direct use, @@ -446,7 +456,10 @@ The return value is the last VAL in the list. ;;;###autoload (defmacro gv-ref (place) "Return a reference to PLACE. -This is like the `&' operator of the C language." +This is like the `&' operator of the C language. +Note: this only works reliably with lexical binding mode, except for very +simple PLACEs such as (function-symbol 'foo) which will also work in dynamic +binding mode." (gv-letplace (getter setter) place `(cons (lambda () ,getter) (lambda (gv--val) ,(funcall setter 'gv--val))))) diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index f3b7de521cf..eca2e22cabc 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -1,9 +1,9 @@ ;;; helper.el --- utility help package supporting help in electric modes -;; Copyright (C) 1985, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1985, 2001-2014 Free Software Foundation, Inc. ;; Author: K. Shane Hartman -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: help ;; Package: emacs @@ -59,7 +59,7 @@ Helper-return-blurb) "return"))) (save-window-excursion - (goto-char (window-start (selected-window))) + (goto-char (window-start)) (if (get-buffer-window "*Help*") (pop-to-buffer "*Help*") (switch-to-buffer "*Help*")) diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index f2e691102d4..9256ad72a3d 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -1,10 +1,10 @@ ;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -;; Copyright (C) 1992, 1994, 1997, 2000-2013 Free Software Foundation, +;; Copyright (C) 1992, 1994, 1997, 2000-2014 Free Software Foundation, ;; Inc. ;; Author: Eric S. Raymond <esr@snark.thyrsus.com> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Created: 14 Jul 1992 ;; Keywords: docs ;; X-Bogus-Bureaucratic-Cruft: Gruad will get you if you don't watch out! @@ -70,11 +70,8 @@ ;; ;; Dave Brennan <brennan@hal.com> ;; ;; Eric Raymond <esr@snark.thyrsus.com> ;; -;; This field may have some special values; notably "FSF", meaning -;; "Free Software Foundation". -;; ;; * Maintainer line --- should be a single name/address as in the Author -;; line, or an address only, or the string "FSF". If there is no maintainer +;; line, or an address only. If there is no maintainer ;; line, the person(s) in the Author field are presumed to be it. ;; The idea behind these two fields is to be able to write a Lisp function ;; that does "send mail to the author" without having to mine the name out by @@ -88,10 +85,9 @@ ;; at a different version of the file than the one they're accustomed to. This ;; may be an RCS or SCCS header. ;; -;; * Adapted-By line --- this is for FSF's internal use. The person named -;; in this field was the one responsible for installing and adapting the -;; package for the distribution. (This file doesn't have one because the -;; author *is* one of the maintainers.) +;; * Adapted-By line --- this was used historically when some files +;; were added to Emacs. The person named in this field installed and +;; (possibly adapted) the package in the Emacs distribution. ;; ;; * Keywords line --- used by the finder code for finding Emacs ;; Lisp code related to a topic. @@ -461,8 +457,8 @@ each line." (let ((keywords (lm-keywords file))) (if keywords (if (string-match-p "," keywords) - (split-string keywords ",[ \t\n]*" t) - (split-string keywords "[ \t\n]+" t))))) + (split-string keywords ",[ \t\n]*" t "[ ]+") + (split-string keywords "[ \t\n]+" t "[ ]+"))))) (defvar finder-known-keywords) (defun lm-keywords-finder-p (&optional file) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 4ebaa0a49d5..7f396b4a344 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1,8 +1,8 @@ -;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands +;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands -*- lexical-binding:t -*- -;; Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1999-2014 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, languages ;; Package: emacs @@ -110,7 +110,9 @@ It has `lisp-mode-abbrev-table' as its parent." "define-compiler-macro" "define-modify-macro" "defsetf" "define-setf-expander" "define-method-combination" - "defgeneric" "defmethod") t)) + "defgeneric" "defmethod" + "cl-defun" "cl-defsubst" "cl-defmacro" + "cl-define-compiler-macro") t)) "\\s-+\\(\\(\\sw\\|\\s_\\)+\\)")) 2) (list (purecopy "Variables") @@ -132,7 +134,8 @@ It has `lisp-mode-abbrev-table' as its parent." (regexp-opt '("defgroup" "deftheme" "deftype" "defstruct" "defclass" "define-condition" "define-widget" - "defface" "defpackage") t)) + "defface" "defpackage" "cl-deftype" + "cl-defstruct") t)) "\\s-+'?\\(\\(\\sw\\|\\s_\\)+\\)")) 2)) @@ -150,6 +153,240 @@ It has `lisp-mode-abbrev-table' as its parent." (defvar lisp-doc-string-elt-property 'doc-string-elt "The symbol property that holds the docstring position info.") + +;;;; Font-lock support. + +(pcase-let + ((`(,vdefs ,tdefs + ,el-defs-re ,cl-defs-re + ,el-kws-re ,cl-kws-re + ,el-errs-re ,cl-errs-re) + (eval-when-compile + (let ((lisp-fdefs '("defmacro" "defsubst" "defun")) + (lisp-vdefs '("defvar")) + (lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1" + "prog2" "lambda" "unwind-protect" "condition-case" + "when" "unless" "with-output-to-string" + "ignore-errors" "dotimes" "dolist" "declare")) + (lisp-errs '("warn" "error" "signal")) + ;; Elisp constructs. FIXME: update dynamically from obarray. + (el-fdefs '("defadvice" "defalias" + "define-derived-mode" "define-minor-mode" + "define-generic-mode" "define-global-minor-mode" + "define-globalized-minor-mode" "define-skeleton" + "define-widget")) + (el-vdefs '("defconst" "defcustom" "defvaralias" "defvar-local" + "defface")) + (el-tdefs '("defgroup" "deftheme")) + (el-kw '("while-no-input" "letrec" "pcase" "pcase-let" + "pcase-let*" "save-restriction" "save-excursion" + "save-selected-window" + ;; "eval-after-load" "eval-next-after-load" + "save-window-excursion" "save-current-buffer" + "save-match-data" "combine-after-change-calls" + "condition-case-unless-debug" "track-mouse" + "eval-and-compile" "eval-when-compile" "with-case-table" + "with-category-table" "with-coding-priority" + "with-current-buffer" "with-demoted-errors" + "with-electric-help" "with-eval-after-load" + "with-local-quit" "with-no-warnings" + "with-output-to-temp-buffer" "with-selected-window" + "with-selected-frame" "with-silent-modifications" + "with-syntax-table" "with-temp-buffer" "with-temp-file" + "with-temp-message" "with-timeout" + "with-timeout-handler")) + (el-errs '("user-error")) + ;; Common-Lisp constructs supported by EIEIO. FIXME: namespace. + (eieio-fdefs '("defgeneric" "defmethod")) + (eieio-tdefs '("defclass")) + (eieio-kw '("with-slots")) + ;; Common-Lisp constructs supported by cl-lib. + (cl-lib-fdefs '("defmacro" "defsubst" "defun")) + (cl-lib-tdefs '("defstruct" "deftype")) + (cl-lib-kw '("progv" "eval-when" "case" "ecase" "typecase" + "etypecase" "ccase" "ctypecase" "loop" "do" "do*" + "the" "locally" "proclaim" "declaim" "letf" "go" + ;; "lexical-let" "lexical-let*" + "symbol-macrolet" "flet" "destructuring-bind" + "labels" "macrolet" "tagbody" "multiple-value-bind" + "block" "return" "return-from")) + (cl-lib-errs '("assert" "check-type")) + ;; Common-Lisp constructs not supported by cl-lib. + (cl-fdefs '("defsetf" "define-method-combination" + "define-condition" "define-setf-expander" + ;; "define-function"?? + "define-compiler-macro" "define-modify-macro")) + (cl-vdefs '("define-symbol-macro" "defconstant" "defparameter")) + (cl-tdefs '("defpackage" "defstruct" "deftype")) + (cl-kw '("prog" "prog*" "handler-case" "handler-bind" + "in-package" "restart-case" ;; "inline" + "restart-bind" "break" "multiple-value-prog1" + "compiler-let" "with-accessors" "with-compilation-unit" + "with-condition-restarts" "with-hash-table-iterator" + "with-input-from-string" "with-open-file" + "with-open-stream" "with-package-iterator" + "with-simple-restart" "with-standard-io-syntax")) + (cl-errs '("abort" "cerror"))) + + (list (append lisp-vdefs el-vdefs cl-vdefs) + (append el-tdefs eieio-tdefs cl-tdefs cl-lib-tdefs + (mapcar (lambda (s) (concat "cl-" s)) cl-lib-tdefs)) + + ;; Elisp and Common Lisp definers. + (regexp-opt (append lisp-fdefs lisp-vdefs + el-fdefs el-vdefs el-tdefs + (mapcar (lambda (s) (concat "cl-" s)) + (append cl-lib-fdefs cl-lib-tdefs)) + eieio-fdefs eieio-tdefs) + t) + (regexp-opt (append lisp-fdefs lisp-vdefs + cl-lib-fdefs cl-lib-tdefs + eieio-fdefs eieio-tdefs + cl-fdefs cl-vdefs cl-tdefs) + t) + + ;; Elisp and Common Lisp keywords. + (regexp-opt (append + lisp-kw el-kw eieio-kw + (cons "go" (mapcar (lambda (s) (concat "cl-" s)) + (remove "go" cl-lib-kw)))) + t) + (regexp-opt (append lisp-kw cl-kw eieio-kw cl-lib-kw) + t) + + ;; Elisp and Common Lisp "errors". + (regexp-opt (append (mapcar (lambda (s) (concat "cl-" s)) + cl-lib-errs) + lisp-errs el-errs) + t) + (regexp-opt (append lisp-errs cl-lib-errs cl-errs) t)))))) + + (dolist (v vdefs) + (put (intern v) 'lisp-define-type 'var)) + (dolist (v tdefs) + (put (intern v) 'lisp-define-type 'type)) + + (define-obsolete-variable-alias 'lisp-font-lock-keywords-1 + 'lisp-el-font-lock-keywords-1 "24.4") + (defconst lisp-el-font-lock-keywords-1 + `( ;; Definitions. + (,(concat "(" el-defs-re "\\_>" + ;; Any whitespace and defined object. + "[ \t'\(]*" + "\\(\\(?:\\sw\\|\\s_\\)+\\)?") + (1 font-lock-keyword-face) + (2 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) + (cond ((eq type 'var) font-lock-variable-name-face) + ((eq type 'type) font-lock-type-face) + (t font-lock-function-name-face))) + nil t)) + ;; Emacs Lisp autoload cookies. Supports the slightly different + ;; forms used by mh-e, calendar, etc. + ("^;;;###\\([-a-z]*autoload\\)" 1 font-lock-warning-face prepend)) + "Subdued level highlighting for Emacs Lisp mode.") + + (defconst lisp-cl-font-lock-keywords-1 + `( ;; Definitions. + (,(concat "(" cl-defs-re "\\_>" + ;; Any whitespace and defined object. + "[ \t'\(]*" + "\\(setf[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") + (1 font-lock-keyword-face) + (2 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) + (cond ((eq type 'var) font-lock-variable-name-face) + ((eq type 'type) font-lock-type-face) + (t font-lock-function-name-face))) + nil t))) + "Subdued level highlighting for Lisp modes.") + + (define-obsolete-variable-alias 'lisp-font-lock-keywords-2 + 'lisp-el-font-lock-keywords-2 "24.4") + (defconst lisp-el-font-lock-keywords-2 + (append + lisp-el-font-lock-keywords-1 + `( ;; Regexp negated char group. + ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend) + ;; Control structures. Common Lisp forms. + (,(concat "(" el-kws-re "\\_>") . 1) + ;; Exit/Feature symbols as constants. + (,(concat "(\\(catch\\|throw\\|featurep\\|provide\\|require\\)\\_>" + "[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?") + (1 font-lock-keyword-face) + (2 font-lock-constant-face nil t)) + ;; Erroneous structures. + (,(concat "(" el-errs-re "\\_>") + (1 font-lock-warning-face)) + ;; Words inside \\[] tend to be for `substitute-command-keys'. + ("\\\\\\\\\\[\\(\\(?:\\sw\\|\\s_\\)+\\)\\]" + (1 font-lock-constant-face prepend)) + ;; Words inside `' tend to be symbol names. + ("`\\(\\(?:\\sw\\|\\s_\\)\\(?:\\sw\\|\\s_\\)+\\)'" + (1 font-lock-constant-face prepend)) + ;; Constant values. + ("\\_<:\\(?:\\sw\\|\\s_\\)+\\_>" 0 font-lock-builtin-face) + ;; ELisp and CLisp `&' keywords as types. + ("\\_<\\&\\(?:\\sw\\|\\s_\\)+\\_>" . font-lock-type-face) + ;; ELisp regexp grouping constructs + (,(lambda (bound) + (catch 'found + ;; The following loop is needed to continue searching after matches + ;; that do not occur in strings. The associated regexp matches one + ;; of `\\\\' `\\(' `\\(?:' `\\|' `\\)'. `\\\\' has been included to + ;; avoid highlighting, for example, `\\(' in `\\\\('. + (while (re-search-forward "\\(\\\\\\\\\\)\\(?:\\(\\\\\\\\\\)\\|\\((\\(?:\\?[0-9]*:\\)?\\|[|)]\\)\\)" bound t) + (unless (match-beginning 2) + (let ((face (get-text-property (1- (point)) 'face))) + (when (or (and (listp face) + (memq 'font-lock-string-face face)) + (eq 'font-lock-string-face face)) + (throw 'found t))))))) + (1 'font-lock-regexp-grouping-backslash prepend) + (3 'font-lock-regexp-grouping-construct prepend)) + ;; This is too general -- rms. + ;; A user complained that he has functions whose names start with `do' + ;; and that they get the wrong color. + ;; ;; CL `with-' and `do-' constructs + ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) + )) + "Gaudy level highlighting for Emacs Lisp mode.") + + (defconst lisp-cl-font-lock-keywords-2 + (append + lisp-cl-font-lock-keywords-1 + `( ;; Regexp negated char group. + ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend) + ;; Control structures. Common Lisp forms. + (,(concat "(" cl-kws-re "\\_>") . 1) + ;; Exit/Feature symbols as constants. + (,(concat "(\\(catch\\|throw\\|provide\\|require\\)\\_>" + "[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?") + (1 font-lock-keyword-face) + (2 font-lock-constant-face nil t)) + ;; Erroneous structures. + (,(concat "(" cl-errs-re "\\_>") + (1 font-lock-warning-face)) + ;; Words inside `' tend to be symbol names. + ("`\\(\\(?:\\sw\\|\\s_\\)\\(?:\\sw\\|\\s_\\)+\\)'" + (1 font-lock-constant-face prepend)) + ;; Constant values. + ("\\_<:\\(?:\\sw\\|\\s_\\)+\\_>" 0 font-lock-builtin-face) + ;; ELisp and CLisp `&' keywords as types. + ("\\_<\\&\\(?:\\sw\\|\\s_\\)+\\_>" . font-lock-type-face) + ;; This is too general -- rms. + ;; A user complained that he has functions whose names start with `do' + ;; and that they get the wrong color. + ;; ;; CL `with-' and `do-' constructs + ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) + )) + "Gaudy level highlighting for Lisp modes.")) + +(define-obsolete-variable-alias 'lisp-font-lock-keywords + 'lisp-el-font-lock-keywords "24.4") +(defvar lisp-el-font-lock-keywords lisp-el-font-lock-keywords-1 + "Default expressions to highlight in Emacs Lisp mode.") +(defvar lisp-cl-font-lock-keywords lisp-cl-font-lock-keywords-1 + "Default expressions to highlight in Lisp modes.") + (defun lisp-font-lock-syntactic-face-function (state) (if (nth 3 state) ;; This might be a (doc)string or a |...| symbol. @@ -187,7 +424,8 @@ It has `lisp-mode-abbrev-table' as its parent." font-lock-string-face)))) font-lock-comment-face)) -(defun lisp-mode-variables (&optional lisp-syntax keywords-case-insensitive) +(defun lisp-mode-variables (&optional lisp-syntax keywords-case-insensitive + elisp) "Common initialization routine for lisp modes. The LISP-SYNTAX argument is used by code in inf-lisp.el and is \(uselessly) passed from pp.el, chistory.el, gnus-kill.el and @@ -222,14 +460,25 @@ font-lock keywords will not be case sensitive." (setq-local comment-use-global-state t) (setq-local imenu-generic-expression lisp-imenu-generic-expression) (setq-local multibyte-syntax-as-symbol t) - (setq-local syntax-begin-function 'beginning-of-defun) + ;; (setq-local syntax-begin-function 'beginning-of-defun) ;;Bug#16247. (setq font-lock-defaults - `((lisp-font-lock-keywords - lisp-font-lock-keywords-1 lisp-font-lock-keywords-2) + `(,(if elisp '(lisp-el-font-lock-keywords + lisp-el-font-lock-keywords-1 + lisp-el-font-lock-keywords-2) + '(lisp-cl-font-lock-keywords + lisp-cl-font-lock-keywords-1 + lisp-cl-font-lock-keywords-2)) nil ,keywords-case-insensitive nil nil (font-lock-mark-block-function . mark-defun) (font-lock-syntactic-face-function - . lisp-font-lock-syntactic-face-function)))) + . lisp-font-lock-syntactic-face-function))) + (setq-local prettify-symbols-alist lisp--prettify-symbols-alist) + ;; electric + (when elisp + (setq-local electric-pair-text-pairs + (cons '(?\` . ?\') electric-pair-text-pairs))) + (setq-local electric-pair-skip-whitespace 'chomp) + (setq-local electric-pair-open-newline-between-pairs nil)) (defun lisp-outline-level () "Lisp mode `outline-level' function." @@ -266,6 +515,7 @@ font-lock keywords will not be case sensitive." (defvar lisp-mode-shared-map (let ((map (make-sparse-keymap))) + (set-keymap-parent map prog-mode-map) (define-key map "\e\C-q" 'indent-sexp) (define-key map "\177" 'backward-delete-char-untabify) ;; This gets in the way when viewing a Lisp file in view-mode. As @@ -394,7 +644,7 @@ font-lock keywords will not be case sensitive." :enable mark-active)) (bindings--define-key menu-map [eval-sexp] '(menu-item "Evaluate Last S-expression" eval-last-sexp - :help "Evaluate sexp before point; print value in minibuffer")) + :help "Evaluate sexp before point; print value in echo area")) (bindings--define-key menu-map [separator-format] menu-bar-separator) (bindings--define-key menu-map [comment-region] '(menu-item "Comment Out Region" comment-region @@ -431,7 +681,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") (defcustom emacs-lisp-mode-hook nil "Hook run when entering Emacs Lisp mode." - :options '(turn-on-eldoc-mode imenu-add-menubar-index checkdoc-minor-mode) + :options '(eldoc-mode imenu-add-menubar-index checkdoc-minor-mode) :type 'hook :group 'lisp) @@ -443,21 +693,22 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") (defcustom lisp-interaction-mode-hook nil "Hook run when entering Lisp Interaction mode." - :options '(turn-on-eldoc-mode) + :options '(eldoc-mode) :type 'hook :group 'lisp) +(defconst lisp--prettify-symbols-alist + '(("lambda" . ?λ))) + (define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp" "Major mode for editing Lisp code to run in Emacs. Commands: Delete converts tabs to spaces as it moves back. Blank lines separate paragraphs. Semicolons start comments. -\\{emacs-lisp-mode-map} -Entry to this mode calls the value of `emacs-lisp-mode-hook' -if that value is non-nil." +\\{emacs-lisp-mode-map}" :group 'lisp - (lisp-mode-variables) + (lisp-mode-variables nil nil 'elisp) (setq imenu-case-fold-search nil) (add-hook 'completion-at-point-functions 'lisp-completion-at-point nil 'local)) @@ -545,10 +796,7 @@ Blank lines separate paragraphs. Semicolons start comments. \\{lisp-mode-map} Note that `run-lisp' may be used either to start an inferior Lisp job -or to switch back to an existing one. - -Entry to this mode calls the value of `lisp-mode-hook' -if that value is non-nil." +or to switch back to an existing one." (lisp-mode-variables nil t) (setq-local find-tag-default-function 'lisp-find-tag-default) (setq-local comment-start-skip @@ -566,7 +814,7 @@ if that value is non-nil." (defalias 'common-lisp-mode 'lisp-mode) ;; This will do unless inf-lisp.el is loaded. -(defun lisp-eval-defun (&optional and-go) +(defun lisp-eval-defun (&optional _and-go) "Send the current defun to the Lisp process made by \\[run-lisp]." (interactive) (error "Process lisp does not exist")) @@ -613,24 +861,25 @@ Delete converts tabs to spaces as it moves back. Paragraphs are separated only by blank lines. Semicolons start comments. -\\{lisp-interaction-mode-map} -Entry to this mode calls the value of `lisp-interaction-mode-hook' -if that value is non-nil." +\\{lisp-interaction-mode-map}" :abbrev-table nil) -(defun eval-print-last-sexp () +(defun eval-print-last-sexp (&optional eval-last-sexp-arg-internal) "Evaluate sexp before point; print value into current buffer. -If `eval-expression-debug-on-error' is non-nil, which is the default, -this command arranges for all errors to enter the debugger. +Normally, this function truncates long output according to the value +of the variables `eval-expression-print-length' and +`eval-expression-print-level'. With a prefix argument of zero, +however, there is no such truncation. Such a prefix argument +also causes integers to be printed in several additional formats +\(octal, hexadecimal, and character). -Note that printing the result is controlled by the variables -`eval-expression-print-length' and `eval-expression-print-level', -which see." - (interactive) +If `eval-expression-debug-on-error' is non-nil, which is the default, +this command arranges for all errors to enter the debugger." + (interactive "P") (let ((standard-output (current-buffer))) (terpri) - (eval-last-sexp t) + (eval-last-sexp (or eval-last-sexp-arg-internal t)) (terpri))) @@ -653,7 +902,7 @@ alternative printed representations that can be displayed." printed-value))))) -(defun last-sexp-toggle-display (&optional arg) +(defun last-sexp-toggle-display (&optional _arg) "Toggle between abbreviated and unabbreviated printed representations." (interactive "P") (save-restriction @@ -772,19 +1021,27 @@ If CHAR is not a character, return nil." (defun eval-last-sexp-1 (eval-last-sexp-arg-internal) - "Evaluate sexp before point; print value in minibuffer. -With argument, print output into current buffer." + "Evaluate sexp before point; print value in the echo area. +With argument, print output into current buffer. +With a zero prefix arg, print output with no limit on the length +and level of lists, and include additional formats for integers +\(octal, hexadecimal, and character)." (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) ;; Setup the lexical environment if lexical-binding is enabled. (eval-last-sexp-print-value - (eval (eval-sexp-add-defvars (preceding-sexp)) lexical-binding)))) + (eval (eval-sexp-add-defvars (preceding-sexp)) lexical-binding) + eval-last-sexp-arg-internal))) -(defun eval-last-sexp-print-value (value) +(defun eval-last-sexp-print-value (value &optional eval-last-sexp-arg-internal) (let ((unabbreviated (let ((print-length nil) (print-level nil)) (prin1-to-string value))) - (print-length eval-expression-print-length) - (print-level eval-expression-print-level) + (print-length (and (not (zerop (prefix-numeric-value + eval-last-sexp-arg-internal))) + eval-expression-print-length)) + (print-level (and (not (zerop (prefix-numeric-value + eval-last-sexp-arg-internal))) + eval-expression-print-level)) (beg (point)) end) (prog1 @@ -808,6 +1065,7 @@ With argument, print output into current buffer." (defun eval-sexp-add-defvars (exp &optional pos) "Prepend EXP with all the `defvar's that precede it in the buffer. POS specifies the starting position where EXP was found and defaults to point." + (setq exp (macroexpand-all exp)) ;Eager macro-expansion. (if (not lexical-binding) exp (save-excursion @@ -825,10 +1083,15 @@ POS specifies the starting position where EXP was found and defaults to point." `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp))))) (defun eval-last-sexp (eval-last-sexp-arg-internal) - "Evaluate sexp before point; print value in minibuffer. + "Evaluate sexp before point; print value in the echo area. Interactively, with prefix argument, print output into current buffer. -Truncates long output according to the value of the variables -`eval-expression-print-length' and `eval-expression-print-level'. + +Normally, this function truncates long output according to the value +of the variables `eval-expression-print-length' and +`eval-expression-print-level'. With a prefix argument of zero, +however, there is no such truncation. Such a prefix argument +also causes integers to be printed in several additional formats +\(octal, hexadecimal, and character). If `eval-expression-debug-on-error' is non-nil, which is the default, this command arranges for all errors to enter the debugger." @@ -891,14 +1154,13 @@ Reinitialize the face according to the `defface' specification." (defun eval-defun-2 () "Evaluate defun that point is in or before. -The value is displayed in the minibuffer. +The value is displayed in the echo area. If the current defun is actually a call to `defvar', then reset the variable using the initial value expression even if the variable already has some other value. \(Normally `defvar' does not change the variable's value if it already has a value.\) -With argument, insert value in current buffer after the defun. Return the result of evaluation." ;; FIXME: the print-length/level bindings should only be applied while ;; printing, not while evaluating. @@ -908,27 +1170,27 @@ Return the result of evaluation." (save-excursion ;; Arrange for eval-region to "read" the (possibly) altered form. ;; eval-region handles recording which file defines a function or - ;; variable. Re-written using `apply' to avoid capturing - ;; variables like `end'. - (apply - #'eval-region - (let ((standard-output t) - beg end form) - ;; Read the form from the buffer, and record where it ends. - (save-excursion - (end-of-defun) - (beginning-of-defun) - (setq beg (point)) - (setq form (read (current-buffer))) - (setq end (point))) - ;; Alter the form if necessary. - (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 - ;; will make eval-region return. - (goto-char ,end) - ',form)))))) + ;; variable. + (let ((standard-output t) + beg end form) + ;; Read the form from the buffer, and record where it ends. + (save-excursion + (end-of-defun) + (beginning-of-defun) + (setq beg (point)) + (setq form (read (current-buffer))) + (setq end (point))) + ;; Alter the form if necessary. + (let ((form (eval-sexp-add-defvars + (eval-defun-1 (macroexpand form))))) + (eval-region beg end standard-output + (lambda (_ignore) + ;; Skipping to the end of the specified region + ;; will make eval-region return. + (goto-char end) + form)))))) + (let ((str (eval-expression-print-format (car values)))) + (if str (princ str))) ;; The result of evaluation has been put onto VALUES. So return it. (car values)) @@ -950,11 +1212,11 @@ this command arranges for all errors to enter the debugger. With a prefix argument, instrument the code for Edebug. If acting on a `defun' for FUNCTION, and the function was -instrumented, `Edebug: FUNCTION' is printed in the minibuffer. If not +instrumented, `Edebug: FUNCTION' is printed in the echo area. If not instrumented, just FUNCTION is printed. If not acting on a `defun', the result of evaluation is displayed in -the minibuffer. This display is controlled by the variables +the echo area. This display is controlled by the variables `eval-expression-print-length' and `eval-expression-print-level', which see." (interactive "P") @@ -993,12 +1255,12 @@ function is `common-lisp-indent-function'." :type 'function :group 'lisp) -(defun lisp-indent-line (&optional whole-exp) +(defun lisp-indent-line (&optional _whole-exp) "Indent current line as Lisp code. With argument, indent any additional lines of the same expression rigidly along with this one." (interactive "P") - (let ((indent (calculate-lisp-indent)) shift-amt end + (let ((indent (calculate-lisp-indent)) shift-amt (pos (- (point-max) (point))) (beg (progn (beginning-of-line) (point)))) (skip-chars-forward " \t") @@ -1038,7 +1300,7 @@ is the buffer position of the start of the containing expression." (save-excursion (beginning-of-line) (let ((indent-point (point)) - state paren-depth + state ;; setting this to a number inhibits calling hook (desired-indent nil) (retry t) @@ -1052,7 +1314,7 @@ is the buffer position of the start of the containing expression." ;; Find innermost containing sexp (while (and retry state - (> (setq paren-depth (elt state 0)) 0)) + (> (elt state 0) 0)) (setq retry nil) (setq calculate-lisp-indent-last-sexp (elt state 2)) (setq containing-sexp (elt state 1)) @@ -1281,7 +1543,7 @@ Lisp function does not specify a special indentation." body-indent normal-indent)))) -(defun lisp-indent-defform (state indent-point) +(defun lisp-indent-defform (state _indent-point) (goto-char (car (cdr state))) (forward-line 1) (if (> (point) (car (cdr (cdr state)))) @@ -1436,6 +1698,8 @@ Any non-integer value means do not use a different value of :type '(choice (integer) (const :tag "Use the current `fill-column'" t)) :group 'lisp) +(put 'emacs-lisp-docstring-fill-column 'safe-local-variable + (lambda (x) (or (eq x t) (integerp x)))) (defun lisp-fill-paragraph (&optional justify) "Like \\[fill-paragraph], but handle Emacs Lisp comments and docstrings. diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 22fb6ad1809..03be2f5c1aa 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -1,9 +1,9 @@ -;;; lisp.el --- Lisp editing commands for Emacs +;;; lisp.el --- Lisp editing commands for Emacs -*- lexical-binding:t -*- -;; Copyright (C) 1985-1986, 1994, 2000-2013 Free Software Foundation, +;; Copyright (C) 1985-1986, 1994, 2000-2014 Free Software Foundation, ;; Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, languages ;; Package: emacs @@ -46,6 +46,12 @@ This affects `insert-parentheses' and `insert-pair'." :group 'lisp) (defvar forward-sexp-function nil + ;; FIXME: + ;; - for some uses, we may want a "sexp-only" version, which only + ;; jumps over a well-formed sexp, rather than some dwimish thing + ;; like jumping from an "else" back up to its "if". + ;; - for up-list, we could use the "sexp-only" behavior as well + ;; to treat the dwimish halfsexp as a form of "up-list" step. "If non-nil, `forward-sexp' delegates to this function. Should take the same arguments and behave similarly to `forward-sexp'.") @@ -53,7 +59,8 @@ Should take the same arguments and behave similarly to `forward-sexp'.") "Move forward across one balanced expression (sexp). With ARG, do it that many times. Negative arg -N means move backward across N balanced expressions. -This command assumes point is not in a string or comment." +This command assumes point is not in a string or comment. +Calls `forward-sexp-function' to do the work, if that is non-nil." (interactive "^p") (or arg (setq arg 1)) (if forward-sexp-function @@ -65,7 +72,8 @@ This command assumes point is not in a string or comment." "Move backward across one balanced expression (sexp). With ARG, do it that many times. Negative arg -N means move forward across N balanced expressions. -This command assumes point is not in a string or comment." +This command assumes point is not in a string or comment. +Uses `forward-sexp' to do the work." (interactive "^p") (or arg (setq arg 1)) (forward-sexp (- arg))) @@ -98,6 +106,8 @@ This command assumes point is not in a string or comment." (defun forward-list (&optional arg) "Move forward across one balanced group of parentheses. +This command will also work on other parentheses-like expressions +defined by the current language mode. With ARG, do it that many times. Negative arg -N means move backward across N groups of parentheses. This command assumes point is not in a string or comment." @@ -107,6 +117,8 @@ This command assumes point is not in a string or comment." (defun backward-list (&optional arg) "Move backward across one balanced group of parentheses. +This command will also work on other parentheses-like expressions +defined by the current language mode. With ARG, do it that many times. Negative arg -N means move forward across N groups of parentheses. This command assumes point is not in a string or comment." @@ -116,6 +128,8 @@ This command assumes point is not in a string or comment." (defun down-list (&optional arg) "Move forward down one level of parentheses. +This command will also work on other parentheses-like expressions +defined by the current language mode. With ARG, do this that many times. A negative argument means move backward but still go down a level. This command assumes point is not in a string or comment." @@ -128,6 +142,8 @@ This command assumes point is not in a string or comment." (defun backward-up-list (&optional arg) "Move backward out of one level of parentheses. +This command will also work on other parentheses-like expressions +defined by the current language mode. With ARG, do this that many times. A negative argument means move forward but still to a less deep spot. This command assumes point is not in a string or comment." @@ -136,6 +152,8 @@ This command assumes point is not in a string or comment." (defun up-list (&optional arg) "Move forward out of one level of parentheses. +This command will also work on other parentheses-like expressions +defined by the current language mode. With ARG, do this that many times. A negative argument means move backward but still to a less deep spot. This command assumes point is not in a string or comment." @@ -256,9 +274,9 @@ is called as a function to find the defun's beginning." ;; convention, fallback on the old implementation. (wrong-number-of-arguments (if (> arg 0) - (dotimes (i arg) + (dotimes (_ arg) (funcall beginning-of-defun-function)) - (dotimes (i (- arg)) + (dotimes (_ (- arg)) (funcall end-of-defun-function)))))) ((or defun-prompt-regexp open-paren-in-column-0-is-defun-start) @@ -436,7 +454,7 @@ it marks the next defun after the ones already marked." (beginning-of-defun)) (re-search-backward "^\n" (- (point) 1) t))))) -(defun narrow-to-defun (&optional arg) +(defun narrow-to-defun (&optional _arg) "Make text outside current defun invisible. The defun visible is the one that contains point or follows point. Optional ARG is ignored." @@ -618,9 +636,10 @@ character." ;; "Unbalanced parentheses", but those may not be so ;; accurate/helpful, e.g. quotes may actually be ;; mismatched. - (error "Unmatched bracket or quote")))) + (user-error "Unmatched bracket or quote")))) (defun field-complete (table &optional predicate) + (declare (obsolete completion-in-region "24.4")) (let ((minibuffer-completion-table table) (minibuffer-completion-predicate predicate) ;; This made sense for lisp-complete-symbol, but for @@ -645,6 +664,7 @@ considered. If the symbol starts just after an open-parenthesis, only symbols with function definitions are considered. Otherwise, all symbols with function definitions, values or properties are considered." + (declare (obsolete completion-at-point "24.4")) (interactive) (let* ((data (lisp-completion-at-point predicate)) (plist (nthcdr 3 data))) @@ -654,10 +674,147 @@ considered." (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data) (plist-get plist :predicate)))))) - -(defun lisp-completion-at-point (&optional predicate) +(defun lisp--local-variables-1 (vars sexp) + "Return the vars locally bound around the witness, or nil if not found." + (let (res) + (while + (unless + (setq res + (pcase sexp + (`(,(or `let `let*) ,bindings) + (let ((vars vars)) + (when (eq 'let* (car sexp)) + (dolist (binding (cdr (reverse bindings))) + (push (or (car-safe binding) binding) vars))) + (lisp--local-variables-1 + vars (car (cdr-safe (car (last bindings))))))) + (`(,(or `let `let*) ,bindings . ,body) + (let ((vars vars)) + (dolist (binding bindings) + (push (or (car-safe binding) binding) vars)) + (lisp--local-variables-1 vars (car (last body))))) + (`(lambda ,_) (setq sexp nil)) + (`(lambda ,args . ,body) + (lisp--local-variables-1 + (append args vars) (car (last body)))) + (`(condition-case ,_ ,e) (lisp--local-variables-1 vars e)) + (`(condition-case ,v ,_ . ,catches) + (lisp--local-variables-1 + (cons v vars) (cdr (car (last catches))))) + (`(,_ . ,_) + (lisp--local-variables-1 vars (car (last sexp)))) + (`lisp--witness--lisp (or vars '(nil))) + (_ nil))) + (setq sexp (ignore-errors (butlast sexp))))) + res)) + +(defun lisp--local-variables () + "Return a list of locally let-bound variables at point." + (save-excursion + (skip-syntax-backward "w_") + (let* ((ppss (syntax-ppss)) + (txt (buffer-substring-no-properties (or (car (nth 9 ppss)) (point)) + (or (nth 8 ppss) (point)))) + (closer ())) + (dolist (p (nth 9 ppss)) + (push (cdr (syntax-after p)) closer)) + (setq closer (apply #'string closer)) + (let* ((sexp (car (read-from-string + (concat txt "lisp--witness--lisp" closer)))) + (macroexpand-advice (lambda (expander form &rest args) + (condition-case nil + (apply expander form args) + (error form)))) + (sexp + (unwind-protect + (progn + (advice-add 'macroexpand :around macroexpand-advice) + (macroexpand-all sexp)) + (advice-remove 'macroexpand macroexpand-advice))) + (vars (lisp--local-variables-1 nil sexp))) + (delq nil + (mapcar (lambda (var) + (and (symbolp var) + (not (string-match (symbol-name var) "\\`[&_]")) + ;; Eliminate uninterned vars. + (intern-soft var) + var)) + vars)))))) + +(defvar lisp--local-variables-completion-table + ;; Use `defvar' rather than `defconst' since defconst would purecopy this + ;; value, which would doubly fail: it would fail because purecopy can't + ;; handle the recursive bytecode object, and it would fail because it would + ;; move `lastpos' and `lastvars' to pure space where they'd be immutable! + (let ((lastpos nil) (lastvars nil)) + (letrec ((hookfun (lambda () + (setq lastpos nil) + (remove-hook 'post-command-hook hookfun)))) + (completion-table-dynamic + (lambda (_string) + (save-excursion + (skip-syntax-backward "_w") + (let ((newpos (cons (point) (current-buffer)))) + (unless (equal lastpos newpos) + (add-hook 'post-command-hook hookfun) + (setq lastpos newpos) + (setq lastvars + (mapcar #'symbol-name (lisp--local-variables)))))) + lastvars))))) + +;; FIXME: Support for Company brings in features which straddle eldoc. +;; We should consolidate this, so that major modes can provide all that +;; data all at once: +;; - a function to extract "the reference at point" (may be more complex +;; than a mere string, to distinguish various namespaces). +;; - a function to jump to such a reference. +;; - a function to show the signature/interface of such a reference. +;; - a function to build a help-buffer about that reference. +;; FIXME: Those functions should also be used by the normal completion code in +;; the *Completions* buffer. + +(defun lisp--company-doc-buffer (str) + (let ((symbol (intern-soft str))) + ;; FIXME: we really don't want to "display-buffer and then undo it". + (save-window-excursion + ;; Make sure we don't display it in another frame, otherwise + ;; save-window-excursion won't be able to undo it. + (let ((display-buffer-overriding-action + '(nil . ((inhibit-switch-frame . t))))) + (ignore-errors + (cond + ((fboundp symbol) (describe-function symbol)) + ((boundp symbol) (describe-variable symbol)) + ((featurep symbol) (describe-package symbol)) + ((facep symbol) (describe-face symbol)) + (t (signal 'user-error nil))) + (help-buffer)))))) + +(defun lisp--company-doc-string (str) + (let* ((symbol (intern-soft str)) + (doc (if (fboundp symbol) + (documentation symbol t) + (documentation-property symbol 'variable-documentation t)))) + (and (stringp doc) + (string-match ".*$" doc) + (match-string 0 doc)))) + +(declare-function find-library-name "find-func" (library)) + +(defun lisp--company-location (str) + (let ((sym (intern-soft str))) + (cond + ((fboundp sym) (find-definition-noselect sym nil)) + ((boundp sym) (find-definition-noselect sym 'defvar)) + ((featurep sym) + (require 'find-func) + (cons (find-file-noselect (find-library-name + (symbol-name sym))) + 0)) + ((facep sym) (find-definition-noselect sym 'defface))))) + +(defun lisp-completion-at-point (&optional _predicate) "Function used for `completion-at-point-functions' in `emacs-lisp-mode'." - ;; FIXME: the `end' could be after point? (with-syntax-table emacs-lisp-mode-syntax-table (let* ((pos (point)) (beg (condition-case nil @@ -666,40 +823,96 @@ considered." (skip-syntax-forward "'") (point)) (scan-error pos))) - (predicate - (or predicate - (save-excursion - (goto-char beg) - (if (not (eq (char-before) ?\()) - (lambda (sym) ;why not just nil ? -sm - (or (boundp sym) (fboundp sym) - (symbol-plist sym))) - ;; Looks like a funcall position. Let's double check. - (if (condition-case nil - (progn (up-list -2) (forward-char 1) - (eq (char-after) ?\()) - (error nil)) - ;; If the first element of the parent list is an open - ;; paren we are probably not in a funcall position. - ;; Maybe a `let' varlist or something. - nil - ;; Else, we assume that a function name is expected. - 'fboundp))))) (end (unless (or (eq beg (point-max)) - (member (char-syntax (char-after beg)) '(?\" ?\( ?\)))) + (member (char-syntax (char-after beg)) + '(?\s ?\" ?\( ?\)))) (condition-case nil (save-excursion (goto-char beg) (forward-sexp 1) (when (>= (point) pos) (point))) - (scan-error pos))))) + (scan-error pos)))) + (funpos (eq (char-before beg) ?\()) ;t if in function position. + (table-etc + (if (not funpos) + ;; FIXME: We could look at the first element of the list and + ;; use it to provide a more specific completion table in some + ;; cases. E.g. filter out keywords that are not understood by + ;; the macro/function being called. + (list nil (completion-table-merge + lisp--local-variables-completion-table + (apply-partially #'completion-table-with-predicate + obarray + ;; Don't include all symbols + ;; (bug#16646). + (lambda (sym) + (or (boundp sym) + (fboundp sym) + (symbol-plist sym))) + 'strict)) + :annotation-function + (lambda (str) (if (fboundp (intern-soft str)) " <f>")) + :company-doc-buffer #'lisp--company-doc-buffer + :company-docsig #'lisp--company-doc-string + :company-location #'lisp--company-location) + ;; Looks like a funcall position. Let's double check. + (save-excursion + (goto-char (1- beg)) + (let ((parent + (condition-case nil + (progn (up-list -1) (forward-char 1) + (let ((c (char-after))) + (if (eq c ?\() ?\( + (if (memq (char-syntax c) '(?w ?_)) + (read (current-buffer)))))) + (error nil)))) + (pcase parent + ;; FIXME: Rather than hardcode special cases here, + ;; we should use something like a symbol-property. + (`declare + (list t (mapcar (lambda (x) (symbol-name (car x))) + (delete-dups + ;; FIXME: We should include some + ;; docstring with each entry. + (append + macro-declarations-alist + defun-declarations-alist))))) + ((and (or `condition-case `condition-case-unless-debug) + (guard (save-excursion + (ignore-errors + (forward-sexp 2) + (< (point) beg))))) + (list t obarray + :predicate (lambda (sym) (get sym 'error-conditions)))) + ((and ?\( + (guard (save-excursion + (goto-char (1- beg)) + (up-list -1) + (forward-symbol -1) + (looking-at "\\_<let\\*?\\_>")))) + (list t obarray + :predicate #'boundp + :company-doc-buffer #'lisp--company-doc-buffer + :company-docsig #'lisp--company-doc-string + :company-location #'lisp--company-location)) + (_ (list nil obarray + :predicate #'fboundp + :company-doc-buffer #'lisp--company-doc-buffer + :company-docsig #'lisp--company-doc-string + :company-location #'lisp--company-location + )))))))) (when end - (list beg end obarray - :predicate predicate - :annotation-function - (unless (eq predicate 'fboundp) - (lambda (str) (if (fboundp (intern-soft str)) " <f>")))))))) + (let ((tail (if (null (car table-etc)) + (cdr table-etc) + (cons + (if (memq (char-syntax (or (char-after end) ?\s)) + '(?\s ?>)) + (cadr table-etc) + (apply-partially 'completion-table-with-terminator + " " (cadr table-etc))) + (cddr table-etc))))) + `(,beg ,end ,@tail)))))) ;;; lisp.el ends here diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 6bb796434fd..e3a746fa69e 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -1,6 +1,6 @@ ;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t; coding: utf-8 -*- ;; -;; Copyright (C) 2004-2013 Free Software Foundation, Inc. +;; Copyright (C) 2004-2014 Free Software Foundation, Inc. ;; ;; Author: Miles Bader <miles@gnu.org> ;; Keywords: lisp, compiler, macros @@ -111,15 +111,20 @@ and also to avoid outputting the warning during normal execution." (funcall (eval (cadr form))) (byte-compile-constant nil))) +(defun macroexp--compiling-p () + "Return non-nil if we're macroexpanding for the compiler." + ;; FIXME: ¡¡Major Ugly Hack!! To determine whether the output of this + ;; macro-expansion will be processed by the byte-compiler, we check + ;; circumstantial evidence. + (member '(declare-function . byte-compile-macroexpand-declare-function) + macroexpand-all-environment)) + + (defun macroexp--warn-and-return (msg form) (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) (cond ((null msg) form) - ;; 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) + ((macroexp--compiling-p) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form)) diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 13202a9ce4d..4675291abeb 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -1,9 +1,9 @@ -;;; map-ynp.el --- general-purpose boolean question-asker +;;; map-ynp.el --- general-purpose boolean question-asker -*- lexical-binding:t -*- -;; Copyright (C) 1991-1995, 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 1991-1995, 2000-2014 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, extensions ;; Package: emacs @@ -34,7 +34,7 @@ ;;; Code: -(declare-function x-popup-dialog "xmenu.c" (position contents &optional header)) +(declare-function x-popup-dialog "menu.c" (position contents &optional header)) (defun map-y-or-n-p (prompter actor list &optional help action-alist no-cursor-in-echo-area) @@ -79,7 +79,7 @@ are meaningful here. Returns the number of actions taken." (let* ((actions 0) - user-keys mouse-event map prompt char elt tail def + user-keys mouse-event map prompt char elt def ;; Non-nil means we should use mouse menus to ask. use-menus delayed-switch-frame @@ -89,13 +89,15 @@ Returns the number of actions taken." (next (if (functionp list) (lambda () (setq elt (funcall list))) (lambda () (when list - (setq elt (pop list)) - t))))) + (setq elt (pop list)) + t)))) + (try-again (lambda () + (let ((x next)) + (setq next (lambda () (setq next x) elt)))))) (if (and (listp last-nonmenu-event) use-dialog-box) ;; Make a list describing a dialog box. - (let ((object (if help (capitalize (nth 0 help)))) - (objects (if help (capitalize (nth 1 help)))) + (let ((objects (if help (capitalize (nth 1 help)))) (action (if help (capitalize (nth 2 help))))) (setq map `(("Yes" . act) ("No" . skip) ,@(mapcar (lambda (elt) @@ -129,8 +131,9 @@ Returns the number of actions taken." (unwind-protect (progn (if (stringp prompter) - (setq prompter `(lambda (object) - (format ,prompter object)))) + (setq prompter (let ((prompter prompter)) + (lambda (object) + (format prompter object))))) (while (funcall next) (setq prompt (funcall prompter elt)) (cond ((stringp prompt) @@ -176,9 +179,7 @@ Returns the number of actions taken." next (lambda () nil))) ((eq def 'quit) (setq quit-flag t) - (setq next `(lambda () - (setq next ',next) - ',elt))) + (funcall try-again)) ((eq def 'automatic) ;; Act on this and all following objects. (if (funcall prompter elt) @@ -219,40 +220,30 @@ the current %s and exit." (with-current-buffer standard-output (help-mode))) - (setq next `(lambda () - (setq next ',next) - ',elt))) - ((and (symbolp def) (commandp def)) - (call-interactively def) - ;; Regurgitated; try again. - (setq next `(lambda () - (setq next ',next) - ',elt))) + (funcall try-again)) + ((and (symbolp def) (commandp def)) + (call-interactively def) + ;; Regurgitated; try again. + (funcall try-again)) ((vectorp def) ;; A user-defined key. (if (funcall (aref def 0) elt) ;Call its function. ;; The function has eaten this object. (setq actions (1+ actions)) ;; Regurgitated; try again. - (setq next `(lambda () - (setq next ',next) - ',elt)))) + (funcall try-again))) ((and (consp char) (eq (car char) 'switch-frame)) ;; switch-frame event. Put it off until we're done. (setq delayed-switch-frame char) - (setq next `(lambda () - (setq next ',next) - ',elt))) + (funcall try-again)) (t ;; Random char. (message "Type %s for help." (key-description (vector help-char))) (beep) (sit-for 1) - (setq next `(lambda () - (setq next ',next) - ',elt))))) + (funcall try-again)))) (prompt (funcall actor elt) (setq actions (1+ actions)))))) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 0632c7d2fc0..8dc1f19784c 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -1,6 +1,6 @@ ;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*- -;; Copyright (C) 2012-2013 Free Software Foundation, Inc. +;; Copyright (C) 2012-2014 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions, lisp, tools @@ -41,10 +41,13 @@ '((:around "\300\301\302\003#\207" 5) (:before "\300\301\002\"\210\300\302\002\"\207" 4) (:after "\300\302\002\"\300\301\003\"\210\207" 5) + (:override "\300\301\"\207" 4) (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4) (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4) (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4) - (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4)) + (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4) + (:filter-args "\300\302\301!\"\207" 5) + (:filter-return "\301\300\302\"!\207" 5)) "List of descriptions of how to add a function. Each element has the form (WHERE BYTECODE STACK) where: WHERE is a keyword indicating where the function is added. @@ -64,8 +67,13 @@ Each element has the form (WHERE BYTECODE STACK) where: (defsubst advice--cdr (f) (aref (aref f 2) 2)) (defsubst advice--props (f) (aref (aref f 2) 3)) -(defun advice--make-docstring (_string function) - "Build the raw doc-string of SYMBOL, presumably advised." +(defun advice--cd*r (f) + (while (advice--p f) + (setq f (advice--cdr f))) + f) + +(defun advice--make-docstring (function) + "Build the raw docstring for FUNCTION, presumably advised." (let ((flist (indirect-function function)) (docstring nil)) (if (eq 'macro (car-safe flist)) (setq flist (cdr flist))) @@ -102,13 +110,6 @@ Each element has the form (WHERE BYTECODE STACK) where: (setq origdoc (cdr usage)) (car usage))) (help-add-fundoc-usage (concat docstring origdoc) usage)))) -(defvar advice--docstring - ;; Can't eval-when-compile nor use defconst because it then gets pure-copied, - ;; which drops the text-properties. - ;;(eval-when-compile - (propertize "Advised function" - 'dynamic-docstring-function #'advice--make-docstring)) ;; ) - (defun advice-eval-interactive-spec (spec) "Evaluate the interactive spec SPEC." (cond @@ -126,8 +127,6 @@ Each element has the form (WHERE BYTECODE STACK) where: ;; TODO: make it so that interactive spec can be a constant which ;; dynamically checks the advice--car/cdr to do its job. ;; For that, advice-eval-interactive-spec needs to be more faithful. - ;; FIXME: The calls to interactive-form below load autoloaded functions - ;; too eagerly. (let ((fspec (cadr (interactive-form function)))) (when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda? (setq fspec (nth 1 fspec))) @@ -143,27 +142,38 @@ Each element has the form (WHERE BYTECODE STACK) where: (advice (apply #'make-byte-code 128 byte-code (vector #'apply function main props) stack-depth - advice--docstring - (when (or (commandp function) (commandp main)) - (list (advice--make-interactive-form - function main)))))) + nil + (and (or (commandp function) (commandp main)) + (not (and (symbolp main) ;; Don't autoload too eagerly! + (autoloadp (symbol-function main)))) + (list (advice--make-interactive-form + function main)))))) (when adv-sig (puthash advice adv-sig advertised-signature-table)) advice)) (defun advice--make (where function main props) "Build a function value that adds FUNCTION to MAIN at WHERE. WHERE is a symbol to select an entry in `advice--where-alist'." - (let ((desc (assq where advice--where-alist))) - (unless desc (error "Unknown add-function location `%S'" where)) - (advice--make-1 (nth 1 desc) (nth 2 desc) - function main props))) - -(defun advice--member-p (function definition) + (let ((fd (or (cdr (assq 'depth props)) 0)) + (md (if (advice--p main) + (or (cdr (assq 'depth (advice--props main))) 0)))) + (if (and md (> fd md)) + ;; `function' should go deeper. + (let ((rest (advice--make where function (advice--cdr main) props))) + (advice--make-1 (aref main 1) (aref main 3) + (advice--car main) rest (advice--props main))) + (let ((desc (assq where advice--where-alist))) + (unless desc (error "Unknown add-function location `%S'" where)) + (advice--make-1 (nth 1 desc) (nth 2 desc) + function main props))))) + +(defun advice--member-p (function name definition) (let ((found nil)) (while (and (not found) (advice--p definition)) (if (or (equal function (advice--car definition)) - (equal function (cdr (assq 'name (advice--props definition))))) - (setq found t) + (when name + (equal name (cdr (assq 'name (advice--props definition)))))) + (setq found definition) (setq definition (advice--cdr definition)))) found)) @@ -189,7 +199,11 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (equal function (cdr (assq 'name props)))) (list rest)))))) -(defvar advice--buffer-local-function-sample nil) +(defvar advice--buffer-local-function-sample nil + "keeps an example of the special \"run the default value\" functions. +These functions play the same role as t in buffer-local hooks, and to recognize +them, we keep a sample here against which to compare. Each instance is +different, but `function-equal' will hopefully ignore those differences.") (defun advice--set-buffer-local (var val) (if (function-equal val advice--buffer-local-function-sample) @@ -202,14 +216,12 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (declare (gv-setter advice--set-buffer-local)) (if (local-variable-p var) (symbol-value var) (setq advice--buffer-local-function-sample + ;; This function acts like the t special value in buffer-local hooks. (lambda (&rest args) (apply (default-value var) args))))) ;;;###autoload (defmacro add-function (where place function &optional props) ;; TODO: - ;; - obsolete with-wrapper-hook (mostly requires buffer-local support). - ;; - provide some kind of control over ordering. E.g. debug-on-entry, ELP - ;; and tracing want to stay first. ;; - maybe let `where' specify some kind of predicate and use it ;; to implement things like mode-local or eieio-defmethod. ;; Of course, that only makes sense if the predicates of all advices can @@ -226,18 +238,24 @@ call OLDFUN here: `:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) `:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r))) `:around' (lambda (&rest r) (apply FUNCTION OLDFUN r)) +`:override' (lambda (&rest r) (apply FUNCTION r)) `:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r))) `:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r))) `:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r))) `:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r))) +`:filter-args' (lambda (&rest r) (apply OLDFUN (funcall FUNCTION r))) +`:filter-return'(lambda (&rest r) (funcall FUNCTION (apply OLDFUN r))) If FUNCTION was already added, do nothing. PROPS is an alist of additional properties, among which the following have a special meaning: - `name': a string or symbol. It can be used to refer to this piece of advice. +- `depth': a number indicating a preference w.r.t ordering. + The default depth is 0. By convention, a depth of 100 means that + the advice should be innermost (i.e. at the end of the list), + whereas a depth of -100 means that the advice should be outermost. -PLACE cannot be a simple variable. Instead it should either be -\(default-value 'VAR) or (local 'VAR) depending on whether FUNCTION -should be applied to VAR buffer-locally or globally. +If PLACE is a simple variable, only its global value will be affected. +Use (local 'VAR) if you want to apply FUNCTION to VAR buffer-locally. If one of FUNCTION or OLDFUN is interactive, then the resulting function is also interactive. There are 3 cases: @@ -250,15 +268,21 @@ is also interactive. There are 3 cases: (cond ((eq 'local (car-safe place)) (setq place `(advice--buffer-local ,@(cdr place)))) ((symbolp place) - (error "Use (default-value '%S) or (local '%S)" place place))) + (setq place `(default-value ',place)))) `(advice--add-function ,where (gv-ref ,place) ,function ,props)) ;;;###autoload (defun advice--add-function (where ref function props) - (unless (advice--member-p function (gv-deref ref)) + (let ((a (advice--member-p function (cdr (assq 'name props)) + (gv-deref ref)))) + (when a + ;; The advice is already present. Remove the old one, first. + (setf (gv-deref ref) + (advice--remove-function (gv-deref ref) (advice--car a)))) (setf (gv-deref ref) (advice--make where function (gv-deref ref) props)))) +;;;###autoload (defmacro remove-function (place function) "Remove the FUNCTION piece of advice from PLACE. If FUNCTION was not added to PLACE, do nothing. @@ -268,11 +292,25 @@ of the piece of advice." (cond ((eq 'local (car-safe place)) (setq place `(advice--buffer-local ,@(cdr place)))) ((symbolp place) - (error "Use (default-value '%S) or (local '%S)" place place))) + (setq place `(default-value ',place)))) (gv-letplace (getter setter) place (macroexp-let2 nil new `(advice--remove-function ,getter ,function) `(unless (eq ,new ,getter) ,(funcall setter new))))) +(defun advice-function-mapc (f function-def) + "Apply F to every advice function in FUNCTION-DEF. +F is called with two arguments: the function that was added, and the +properties alist that was specified when it was added." + (while (advice--p function-def) + (funcall f (advice--car function-def) (advice--props function-def)) + (setq function-def (advice--cdr function-def)))) + +(defun advice-function-member-p (advice function-def) + "Return non-nil if ADVICE is already in FUNCTION-DEF. +Instead of ADVICE being the actual function, it can also be the `name' +of the piece of advice." + (advice--member-p advice advice function-def)) + ;;;; Specific application of add-function to `symbol-function' for advice. (defun advice--subst-main (old new) @@ -283,11 +321,10 @@ of the piece of advice." (cond ((special-form-p def) ;; Not worth the trouble trying to handle this, I think. - (error "advice-add failure: %S is a special form" symbol)) - ((and (symbolp def) - (eq 'macro (car-safe (ignore-errors (indirect-function def))))) - (let ((newval (cons 'macro (cdr (indirect-function def))))) - (put symbol 'advice--saved-rewrite (cons def newval)) + (error "Advice impossible: %S is a special form" symbol)) + ((and (symbolp def) (macrop def)) + (let ((newval `(macro . ,(lambda (&rest r) (macroexpand `(,def . ,r)))))) + (put symbol 'advice--saved-rewrite (cons def (cdr newval))) newval)) ;; `f' might be a pure (hence read-only) cons! ((and (eq 'macro (car-safe def)) @@ -298,31 +335,39 @@ of the piece of advice." (defsubst advice--strip-macro (x) (if (eq 'macro (car-safe x)) (cdr x) x)) +(defun advice--symbol-function (symbol) + ;; The value conceptually stored in `symbol-function' is split into two + ;; parts: + ;; - the normal function definition. + ;; - the list of advice applied to it. + ;; `advice--symbol-function' is intended to return the second part (i.e. the + ;; list of advice, which includes a hole at the end which typically holds the + ;; first part, but this function doesn't care much which value is found + ;; there). + ;; In the "normal" state both parts are combined into a single value stored + ;; in the "function slot" of the symbol. But the way they are combined is + ;; different depending on whether the definition is a function or a macro. + ;; Also if the function definition is nil (i.e. unbound) or is an autoload, + ;; the second part is stashed away temporarily in the `advice--pending' + ;; symbol property. + (or (get symbol 'advice--pending) + (advice--strip-macro (symbol-function symbol)))) + (defun advice--defalias-fset (fsetfun symbol newdef) + (unless fsetfun (setq fsetfun #'fset)) (when (get symbol 'advice--saved-rewrite) (put symbol 'advice--saved-rewrite nil)) (setq newdef (advice--normalize symbol newdef)) - (let* ((olddef (advice--strip-macro - (if (fboundp symbol) (symbol-function symbol)))) - (oldadv - (cond - ((null (get symbol 'advice--pending)) - (or olddef - (progn - (message "Delayed advice activation failed for %s: no data" - symbol) - nil))) - ((or (not olddef) (autoloadp olddef)) - (prog1 (get symbol 'advice--pending) - (put symbol 'advice--pending nil))) - (t (message "Dropping left-over advice--pending for %s" symbol) - (put symbol 'advice--pending nil) - olddef)))) - (let* ((snewdef (advice--strip-macro newdef)) - (snewadv (advice--subst-main oldadv snewdef))) - (funcall (or fsetfun #'fset) symbol - (if (eq snewdef newdef) snewadv (cons 'macro snewadv)))))) - + (let ((oldadv (advice--symbol-function symbol))) + (if (and newdef (not (autoloadp newdef))) + (let* ((snewdef (advice--strip-macro newdef)) + (snewadv (advice--subst-main oldadv snewdef))) + (put symbol 'advice--pending nil) + (funcall fsetfun symbol + (if (eq snewdef newdef) snewadv (cons 'macro snewadv)))) + (unless (eq oldadv (get symbol 'advice--pending)) + (put symbol 'advice--pending (advice--subst-main oldadv nil))) + (funcall fsetfun symbol newdef)))) ;;;###autoload (defun advice-add (symbol where function &optional props) @@ -332,12 +377,10 @@ is defined as a macro, alias, command, ..." ;; TODO: ;; - record the advice location, to display in describe-function. ;; - change all defadvice in lisp/**/*.el. - ;; - rewrite advice.el on top of this. ;; - obsolete advice.el. - (let* ((f (and (fboundp symbol) (symbol-function symbol))) + (let* ((f (symbol-function symbol)) (nf (advice--normalize symbol f))) - (unless (eq f nf) ;; Most importantly, if nf == nil! - (fset symbol nf)) + (unless (eq f nf) (fset symbol nf)) (add-function where (cond ((eq (car-safe nf) 'macro) (cdr nf)) ;; Reasons to delay installation of the advice: @@ -352,6 +395,7 @@ is defined as a macro, alias, command, ..." (get symbol 'advice--pending)) (t (symbol-function symbol))) function props) + (put symbol 'function-documentation `(advice--make-docstring ',symbol)) (add-function :around (get symbol 'defalias-fset-function) #'advice--defalias-fset)) nil) @@ -359,48 +403,39 @@ is defined as a macro, alias, command, ..." ;;;###autoload (defun advice-remove (symbol function) "Like `remove-function' but for the function named SYMBOL. -Contrary to `remove-function', this will work also when SYMBOL is a macro -and it will not signal an error if SYMBOL is not `fboundp'. +Contrary to `remove-function', this also works when SYMBOL is a macro +or an autoload and it preserves `fboundp'. Instead of the actual function to remove, FUNCTION can also be the `name' of the piece of advice." - (when (fboundp symbol) - (let ((f (symbol-function symbol))) - ;; Can't use the `if' place here, because the body is too large, - ;; resulting in use of code that only works with lexical-scoping. - (remove-function (if (eq (car-safe f) 'macro) - (cdr f) - (symbol-function symbol)) - function) - (unless (advice--p - (if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol))) - ;; Not advised any more. - (remove-function (get symbol 'defalias-fset-function) - #'advice--defalias-fset) - (if (eq (symbol-function symbol) - (cdr (get symbol 'advice--saved-rewrite))) - (fset symbol (car (get symbol 'advice--saved-rewrite)))))) - nil)) - -;; (defun advice-mapc (fun symbol) -;; "Apply FUN to every function added as advice to SYMBOL. -;; FUN is called with a two arguments: the function that was added, and the -;; properties alist that was specified when it was added." -;; (let ((def (or (get symbol 'advice--pending) -;; (if (fboundp symbol) (symbol-function symbol))))) -;; (while (advice--p def) -;; (funcall fun (advice--car def) (advice--props def)) -;; (setq def (advice--cdr def))))) + (let ((f (symbol-function symbol))) + (remove-function (cond ;This is `advice--symbol-function' but as a "place". + ((get symbol 'advice--pending) + (get symbol 'advice--pending)) + ((eq (car-safe f) 'macro) (cdr f)) + (t (symbol-function symbol))) + function) + (unless (advice--p (advice--symbol-function symbol)) + ;; Not advised any more. + (remove-function (get symbol 'defalias-fset-function) + #'advice--defalias-fset) + (let ((asr (get symbol 'advice--saved-rewrite))) + (and asr (eq (cdr-safe (symbol-function symbol)) + (cdr asr)) + (fset symbol (car (get symbol 'advice--saved-rewrite))))))) + nil) + +(defun advice-mapc (fun symbol) + "Apply FUN to every advice function in SYMBOL. +FUN is called with a two arguments: the function that was added, and the +properties alist that was specified when it was added." + (advice-function-mapc fun (advice--symbol-function symbol))) ;;;###autoload -(defun advice-member-p (advice function-name) - "Return non-nil if ADVICE has been added to FUNCTION-NAME. +(defun advice-member-p (advice symbol) + "Return non-nil if ADVICE has been added to SYMBOL. Instead of ADVICE being the actual function, it can also be the `name' of the piece of advice." - (advice--member-p advice - (or (get function-name 'advice--pending) - (advice--strip-macro - (if (fboundp function-name) - (symbol-function function-name)))))) + (advice-function-member-p advice (advice--symbol-function symbol))) ;; When code is advised, called-interactively-p needs to be taught to skip ;; the advising frames. @@ -416,7 +451,7 @@ of the piece of advice." (get-next-frame (lambda () (setq frame1 frame2) - (setq frame2 (internal--called-interactively-p--get-frame i)) + (setq frame2 (backtrace-frame i #'called-interactively-p)) ;; (message "Advice Frame %d = %S" i frame2) (setq i (1+ i))))) (when (and (eq (nth 1 frame2) 'apply) diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index a3ce1672a63..6a6a62dc916 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -1,10 +1,9 @@ ;;; package-x.el --- Package extras -;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2014 Free Software Foundation, Inc. ;; Author: Tom Tromey <tromey@redhat.com> ;; Created: 10 Mar 2007 -;; Version: 0.9 ;; Keywords: tools ;; Package: package @@ -162,9 +161,11 @@ DESCRIPTION is the text of the news item." description archive-url)) -(defun package-upload-buffer-internal (pkg-info extension &optional archive-url) +(declare-function lm-commentary "lisp-mnt" (&optional file)) + +(defun package-upload-buffer-internal (pkg-desc extension &optional archive-url) "Upload a package whose contents are in the current buffer. -PKG-INFO is the package info, see `package-buffer-info'. +PKG-DESC is the `package-desc'. EXTENSION is the file extension, a string. It can be either \"el\" or \"tar\". @@ -196,32 +197,34 @@ if it exists." (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) "") + (let* ((file-type (package-desc-kind pkg-desc)) + (pkg-name (package-desc-name pkg-desc)) + (requires (package-desc-reqs pkg-desc)) + (desc (if (eq (package-desc-summary pkg-desc) + package--default-summary) (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)) + (package-desc-summary pkg-desc))) + (split-version (package-desc-version pkg-desc)) + (commentary + (pcase file-type + (`single (lm-commentary)) + (`tar nil))) ;; FIXME: Get it from the README file. + (extras (package-desc-extras pkg-desc)) + (pkg-version (package-version-join split-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))) + (new-desc (package-make-ac-desc + split-version requires desc file-type extras))) (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))) + (package--ac-desc-version (cdr elt))) (error "New package has smaller version: %s" pkg-version) (setcdr elt new-desc)) (setq contents (cons (car contents) @@ -232,6 +235,7 @@ if it exists." ;; this and the package itself. For now we assume ELPA is ;; writable via file primitives. (let ((print-level nil) + (print-quoted t) (print-length nil)) (write-region (concat (pp-to-string contents) "\n") nil @@ -241,29 +245,29 @@ if it exists." ;; 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))) + (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) + (format "%s-%s.%s" pkg-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) + (package--update-news (format "%s.%s" pkg-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") + (if (eq pkg-name 'package) (write-region (point-min) (point-max) (expand-file-name - (concat file-name "." extension) + (format "%s.%s" pkg-name extension) package-archive-upload-base) nil nil nil 'ask)))))))) @@ -275,8 +279,8 @@ destination, prompt for one." (save-excursion (save-restriction ;; Find the package in this buffer. - (let ((pkg-info (package-buffer-info))) - (package-upload-buffer-internal pkg-info "el"))))) + (let ((pkg-desc (package-buffer-info))) + (package-upload-buffer-internal pkg-desc "el"))))) (defun package-upload-file (file) "Upload the Emacs Lisp package FILE to the package archive. @@ -287,13 +291,15 @@ 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))))) + (insert-file-contents file) + (let ((pkg-desc + (cond + ((string-match "\\.tar\\'" file) + (tar-mode) (package-tar-file-info)) + ((string-match "\\.el\\'" file) (package-buffer-info)) + (t (error "Unrecognized extension `%s'" + (file-name-extension file)))))) + (package-upload-buffer-internal pkg-desc (file-name-extension file))))) (defun package-gnus-summary-upload () "Upload a package contained in the current *Article* buffer. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c15c9e079fe..b15ae6f1376 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1,11 +1,13 @@ -;;; package.el --- Simple package system for Emacs +;;; package.el --- Simple package system for Emacs -*- lexical-binding:t -*- -;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2014 Free Software Foundation, Inc. ;; Author: Tom Tromey <tromey@redhat.com> +;; Daniel Hackney <dan@haxney.org> ;; Created: 10 Mar 2007 -;; Version: 1.0 +;; Version: 1.0.1 ;; Keywords: tools +;; Package-Requires: ((tabulated-list "1.0")) ;; This file is part of GNU Emacs. @@ -139,7 +141,6 @@ ;; 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 @@ -158,17 +159,12 @@ ;; - 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: +(eval-when-compile (require 'cl-lib)) + (require 'tabulated-list) (defgroup package nil @@ -197,8 +193,7 @@ 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 t, the most recent version is 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. @@ -211,9 +206,12 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")." (defvar Info-directory-list) (declare-function info-initialize "info" ()) (declare-function url-http-parse-response "url-http" ()) +(declare-function url-http-file-exists-p "url-http" (url)) (declare-function lm-header "lisp-mnt" (header)) (declare-function lm-commentary "lisp-mnt" (&optional file)) (defvar url-http-end-of-headers) +(declare-function url-recreate-url "url-parse" (urlobj)) +(defvar url-http-target-url) (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) "An alist of archives from which to fetch. @@ -234,21 +232,32 @@ a package can run arbitrary code." :group 'package :version "24.1") +(defcustom package-pinned-packages nil + "An alist of packages that are pinned to a specific archive + +Each element has the form (SYM . ID). + SYM is a package, as a symbol. + ID is an archive name. This should correspond to an + entry in `package-archives'. + +If the archive of name ID does not contain the package SYM, no +other location will be considered, which will make the +package unavailable." + :type '(alist :key-type (symbol :tag "Package") + :value-type (string :tag "Archive name")) + :risky t + :group 'package + :version "24.4") + (defconst package-archive-version 1 "Version number of the package archive understood by this file. Lower version numbers than this will probably be understood as well.") -(defconst package-el-version "1.0" - "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.") +This is an alist mapping package names (symbols) to +non-empty lists of `package-desc' structures.") (put 'package-archive-contents 'risky-local-variable t) (defcustom package-user-dir (locate-user-emacs-file "elpa") @@ -279,35 +288,134 @@ contrast, `package-user-dir' contains packages for personal use." :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). +(defcustom package-check-signature 'allow-unsigned + "Whether to check package signatures when installing." + :type '(choice (const nil :tag "Never") + (const allow-unsigned :tag "Allow unsigned") + (const t :tag "Check always")) + :risky t + :group 'package + :version "24.1") + +(defcustom package-unsigned-archives nil + "A list of archives which do not use package signature." + :type '(repeat (string :tag "Archive name")) + :risky t + :group 'package + :version "24.1") + +(defvar package--default-summary "No description available.") + +(cl-defstruct (package-desc + ;; Rename the default constructor from `make-package-desc'. + (:constructor package-desc-create) + ;; Has the same interface as the old `define-package', + ;; which is still used in the "foo-pkg.el" files. Extra + ;; options can be supported by adding additional keys. + (:constructor + package-desc-from-define + (name-string version-string &optional summary requirements + &rest rest-plist + &aux + (name (intern name-string)) + (version (version-to-list version-string)) + (reqs (mapcar #'(lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) + (if (eq 'quote (car requirements)) + (nth 1 requirements) + requirements))) + (kind (plist-get rest-plist :kind)) + (archive (plist-get rest-plist :archive)) + (extras (let (alist) + (while rest-plist + (unless (memq (car rest-plist) '(:kind :archive)) + (let ((value (cadr rest-plist))) + (when value + (push (cons (car rest-plist) + (if (eq (car-safe value) 'quote) + (cdr value) + value)) + alist)))) + (setq rest-plist (cddr rest-plist))) + alist))))) + "Structure containing information about an individual package. +Slots: + +`name' Name of the package, as a symbol. + +`version' Version of the package, as a version list. + +`summary' Short description of the package, typically taken from + the first line of the file. + +`reqs' Requirements of the package. A list of (PACKAGE + VERSION-LIST) naming the dependent package and the minimum + required version. + +`kind' The distribution format of the package. Currently, it is + either `single' or `tar'. + +`archive' The name of the archive (as a string) whence this + package came. + +`dir' The directory where the package is installed (if installed), + `builtin' if it is built-in, or nil otherwise. + +`extras' Optional alist of additional keyword-value pairs. + +`signed' Flag to indicate that the package is signed by provider." + name + version + (summary package--default-summary) + reqs + kind + archive + dir + extras + signed) + +;; Pseudo fields. +(defun package-desc-full-name (pkg-desc) + (format "%s-%s" + (package-desc-name pkg-desc) + (package-version-join (package-desc-version pkg-desc)))) + +(defun package-desc-suffix (pkg-desc) + (pcase (package-desc-kind pkg-desc) + (`single ".el") + (`tar ".tar") + (kind (error "Unknown package kind: %s" kind)))) + +(defun package-desc--keywords (pkg-desc) + (let ((keywords (cdr (assoc :keywords (package-desc-extras pkg-desc))))) + (if (eq (car-safe keywords) 'quote) + (nth 1 keywords) + keywords))) + +;; Package descriptor format used in finder-inf.el and package--builtins. +(cl-defstruct (package--bi-desc + (:constructor package-make-builtin (version summary)) + (:type vector)) + version + reqs + summary) + (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.") +Each element has the form (PKG . PACKAGE-BI-DESC), where PKG is a package +name (a symbol) and DESC is a `package--bi-desc' structure.") (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. +Each element has the form (PKG . DESCS), where PKG is a package +name (a symbol) and DESCS is a non-empty list of `package-desc' structure, +sorted by decreasing versions. This variable is set automatically by `package-load-descriptor', called via `package-initialize'. To change which packages are @@ -315,15 +423,10 @@ loaded and/or activated, customize `package-load-list'.") (put 'package-alist 'risky-local-variable t) (defvar package-activated-list nil + ;; FIXME: This should implicitly include all builtin packages. "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'. @@ -337,7 +440,7 @@ This is, approximately, the inverse of `version-to-list'. ((>= num 0) (push (int-to-string num) str-list) (push "." str-list)) - ((< num -3) + ((< num -4) (error "Invalid version list `%s'" vlist)) (t ;; pre, or beta, or alpha @@ -347,29 +450,28 @@ This is, approximately, the inverse of `version-to-list'. (error "Invalid version list `%s'" vlist))) (push (cond ((= num -1) "pre") ((= num -2) "beta") - ((= num -3) "alpha")) + ((= num -3) "alpha") + ((= num -4) "snapshot")) 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-descriptor (pkg-dir) + "Load the description file in directory PKG-DIR." + (let ((pkg-file (expand-file-name (package--description-file pkg-dir) + pkg-dir)) + (signed-file (concat pkg-dir ".signed"))) + (when (file-exists-p pkg-file) + (with-temp-buffer + (insert-file-contents pkg-file) + (goto-char (point-min)) + (let ((pkg-desc (package-process-define-package + (read (current-buffer)) pkg-file))) + (setf (package-desc-dir pkg-desc) pkg-dir) + (if (file-exists-p signed-file) + (setf (package-desc-signed pkg-desc) t)) + pkg-desc))))) (defun package-load-all-descriptors () "Load descriptors for installed Emacs Lisp packages. @@ -379,86 +481,53 @@ 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))) +updates `package-alist'." + (dolist (dir (cons package-user-dir package-directory-list)) + (when (file-directory-p dir) + (dolist (subdir (directory-files dir)) + (let ((pkg-dir (expand-file-name subdir dir))) + (when (file-directory-p pkg-dir) + (package-load-descriptor pkg-dir))))))) + +(defun package-disabled-p (pkg-name version) + "Return whether PKG-NAME at VERSION can be activated. +The decision is made according to `package-load-list'. +Return nil if the package can be activated. +Return t if the package is completely disabled. +Return the max version (as a string) if the package is held at a lower version." + (let ((force (assq pkg-name package-load-list))) + (cond ((null force) (not (memq 'all package-load-list))) + ((null (setq force (cadr force))) t) ; disabled + ((eq force t) nil) + ((stringp force) ; held + (unless (version-list-= version (version-to-list force)) + force)) + (t (error "Invalid element in `package-load-list'"))))) + +(defun package-activate-1 (pkg-desc) + (let* ((name (package-desc-name pkg-desc)) + (pkg-dir (package-desc-dir pkg-desc)) + (pkg-dir-dir (file-name-as-directory pkg-dir))) (unless pkg-dir - (error "Internal error: unable to find directory for `%s-%s'" - name version-str)) + (error "Internal error: unable to find directory for `%s'" + (package-desc-full-name pkg-desc))) + ;; Add to load path, add autoloads, and activate the package. + (let ((old-lp load-path)) + (with-demoted-errors + (load (expand-file-name (format "%s-autoloads" name) pkg-dir) nil t)) + (when (and (eq old-lp load-path) + (not (or (member pkg-dir load-path) + (member pkg-dir-dir load-path)))) + ;; Old packages don't add themselves to the `load-path', so we have to + ;; do it ourselves. + (push pkg-dir load-path))) ;; 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) + (push name package-activated-list) ;; Don't return nil. t)) @@ -466,66 +535,63 @@ NAME and VERSION are both strings." "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))))))) + (if (package-desc-p package) ;; was built-in and then was converted + (eq 'builtin (package-desc-dir package)) + (let ((bi (assq package package--builtin-versions))) + (cond + (bi (version-list-<= min-version (cdr bi))) + (min-version nil) + (t + (require 'finder-inf nil t) ; For `package--builtins'. + (assq package package--builtins)))))) + +(defun package--from-builtin (bi-desc) + (package-desc-create :name (pop bi-desc) + :version (package--bi-desc-version bi-desc) + :summary (package--bi-desc-summary bi-desc) + :dir 'builtin)) ;; 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) +(defun package-activate (package &optional force) + "Activate package PACKAGE. +If FORCE is true, (re-)activate it if it's already activated." + (let ((pkg-descs (cdr (assq package package-alist)))) ;; 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))) + (while + (when pkg-descs + (let ((available-version (package-desc-version (car pkg-descs)))) + (or (package-disabled-p package available-version) + ;; Prefer a builtin package. + (package-built-in-p package available-version)))) + (setq pkg-descs (cdr pkg-descs))) (cond ;; If no such package is found, maybe it's built-in. - ((null found) - (package-built-in-p package min-version)) + ((null pkg-descs) + (package-built-in-p package)) ;; If the package is already activated, just return t. - ((memq package package-activated-list) + ((and (memq package package-activated-list) (not force)) 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)))))) + (let* ((pkg-vec (car pkg-descs)) + (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) + (package-activate-1 pkg-vec))))))) + +(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. @@ -535,35 +601,30 @@ REQUIREMENTS is a list of dependencies on other packages. 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. + ;; FIXME: Placeholder! Should we keep it? + (error "Don't call me!")) + +(defun package-process-define-package (exp origin) + (unless (eq (car-safe exp) 'define-package) + (error "Can't find define-package in %s" origin)) + (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp))) + (name (package-desc-name new-pkg-desc)) + (version (package-desc-version new-pkg-desc)) + (old-pkgs (assq name package-alist))) + (if (null old-pkgs) + ;; If there's no old package, just add this to `package-alist'. + (push (list name new-pkg-desc) package-alist) + ;; If there is, insert the new package at the right place in the list. + (while + (if (and (cdr old-pkgs) + (version-list-< version + (package-desc-version (cadr old-pkgs)))) + (setq old-pkgs (cdr old-pkgs)) + (push new-pkg-desc (cdr old-pkgs)) + nil))) + new-pkg-desc)) + +;; From Emacs 22, but changed so it adds to load-path. (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) @@ -571,7 +632,8 @@ EXTRA-PROPERTIES is currently unused." (concat ";;; " (file-name-nondirectory file) " --- automatically extracted autoloads\n" ";;\n" - ";;; Code:\n\n" + ";;; Code:\n" + "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n" " \n;; Local Variables:\n" ";; version-control: never\n" ";; no-byte-compile: t\n" @@ -579,25 +641,27 @@ EXTRA-PROPERTIES is currently unused." ";; End:\n" ";;; " (file-name-nondirectory file) " ends here\n") - nil file)) + nil file nil 'silent)) file) +(defvar generated-autoload-file) +(defvar version-control) + (defun package-generate-autoloads (name pkg-dir) - (require 'autoload) ;Load before we let-bind generated-autoload-file! - (let* ((auto-name (concat name "-autoloads.el")) + (let* ((auto-name (format "%s-autoloads.el" name)) ;;(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)) + (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))))) + (when buf (kill-buffer buf))) + auto-name)) (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)) +(declare-function tar-header-name "tar-mode" (tar-header) t) +(declare-function tar-header-link-type "tar-mode" (tar-header) t) (defun package-untar-buffer (dir) "Untar the current buffer. @@ -618,65 +682,83 @@ untar into a directory named DIR; otherwise, signal an error." (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)) +(defun package-generate-description-file (pkg-desc pkg-dir) + "Create the foo-pkg.el file for single-file packages." + (let* ((name (package-desc-name pkg-desc)) + (pkg-file (expand-file-name (package--description-file pkg-dir) + pkg-dir))) + (let ((print-level nil) + (print-quoted t) + (print-length nil)) + (write-region + (concat + (prin1-to-string + (nconc + (list 'define-package + (symbol-name name) + (package-version-join (package-desc-version pkg-desc)) + (package-desc-summary pkg-desc) + (let ((requires (package-desc-reqs pkg-desc))) + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (cadr elt)))) + requires)))) + (package--alist-to-plist + (package-desc-extras pkg-desc)))) + "\n") + nil pkg-file nil 'silent)))) + +(defun package--alist-to-plist (alist) + (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist))) + +(defun package-unpack (pkg-desc) + "Install the contents of the current buffer as a package." + (let* ((name (package-desc-name pkg-desc)) + (dirname (package-desc-full-name pkg-desc)) (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))) + (pcase (package-desc-kind pkg-desc) + (`tar + (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))) + (`single + (let ((el-file (expand-file-name (format "%s.el" name) pkg-dir))) + (make-directory pkg-dir t) + (package--write-file-no-coding el-file))) + (kind (error "Unknown package kind: %S" kind))) + (package--make-autoloads-and-stuff pkg-desc pkg-dir) + ;; Update package-alist. + (let ((new-desc (package-load-descriptor pkg-dir))) + ;; FIXME: Check that `new-desc' matches `desc'! + ;; FIXME: Compilation should be done as a separate, optional, step. + ;; E.g. for multi-package installs, we should first install all packages + ;; and then compile them. + (package--compile new-desc)) + ;; Try to activate it. + (package-activate name 'force) + pkg-dir)) + +(defun package--make-autoloads-and-stuff (pkg-desc pkg-dir) + "Generate autoloads, description file, etc.. for PKG-DESC installed at PKG-DIR." + (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir) + (let ((desc-file (package--description-file pkg-dir))) + (unless (file-exists-p desc-file) + (package-generate-description-file pkg-desc pkg-dir))) + ;; FIXME: Create foo.info and dir file from foo.texi? + ) + +(defun package--compile (pkg-desc) + "Byte-compile installed package PKG-DESC." + (package-activate-1 pkg-desc) + (byte-recompile-directory (package-desc-dir pkg-desc) 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)))) + (write-region (point-min) (point-max) file-name nil 'silent))) (defmacro package--with-work-buffer (location file &rest body) "Run BODY in a buffer containing the contents of FILE at LOCATION. @@ -687,6 +769,7 @@ 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." + (declare (indent 2) (debug t)) `(let* ((http (string-match "\\`https?:" ,location)) (buffer (if http @@ -716,24 +799,88 @@ It will move point to somewhere in the headers." (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)))) + (error "Error downloading %s:%s" + (url-recreate-url url-http-target-url) + (buffer-substring-no-properties (point) (line-end-position)))))) -(defun package-download-tar (name version) +(defun package--archive-file-exists-p (location file) + (let ((http (string-match "\\`https?:" location))) + (if http + (progn + (require 'url-http) + (url-http-file-exists-p (concat location file))) + (file-exists-p (expand-file-name file location))))) + +(declare-function epg-make-context "epg" + (&optional protocol armor textmode include-certs + cipher-algorithm + digest-algorithm + compress-algorithm)) +(declare-function epg-context-set-home-directory "epg" (context directory)) +(declare-function epg-verify-string "epg" (context signature + &optional signed-text)) +(declare-function epg-context-result-for "epg" (context name)) +(declare-function epg-signature-status "epg" (signature)) +(declare-function epg-signature-to-string "epg" (signature)) + +(defun package--check-signature (location file) + "Check signature of the current buffer. +GnuPG keyring is located under \"gnupg\" in `package-user-dir'." + (let* ((context (epg-make-context 'OpenPGP)) + (homedir (expand-file-name "gnupg" package-user-dir)) + (sig-file (concat file ".sig")) + (sig-content (package--with-work-buffer location sig-file + (buffer-string)))) + (epg-context-set-home-directory context homedir) + (epg-verify-string context sig-content (buffer-string)) + ;; The .sig file may contain multiple signatures. Success if one + ;; of the signatures is good. + (let ((good-signatures + (delq nil (mapcar (lambda (sig) + (if (eq (epg-signature-status sig) 'good) + sig)) + (epg-context-result-for context 'verify))))) + (if (null good-signatures) + (error "Failed to verify signature %s: %S" + sig-file + (mapcar #'epg-signature-to-string + (epg-context-result-for context 'verify))) + good-signatures)))) + +(defun package-install-from-archive (pkg-desc) "Download and install a tar package." - (let ((location (package-archive-base name)) - (file (concat (symbol-name name) "-" version ".tar"))) + (let* ((location (package-archive-base pkg-desc)) + (file (concat (package-desc-full-name pkg-desc) + (package-desc-suffix pkg-desc))) + (sig-file (concat file ".sig")) + good-signatures pkg-descs) (package--with-work-buffer location file - (package-unpack name version)))) + (if (and package-check-signature + (not (member (package-desc-archive pkg-desc) + package-unsigned-archives))) + (if (package--archive-file-exists-p location sig-file) + (setq good-signatures (package--check-signature location file)) + (unless (eq package-check-signature 'allow-unsigned) + (error "Unsigned package: `%s'" + (package-desc-name pkg-desc))))) + (package-unpack pkg-desc)) + ;; Here the package has been installed successfully, mark it as + ;; signed if appropriate. + (when good-signatures + ;; Write out good signatures into NAME-VERSION.signed file. + (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") + nil + (expand-file-name + (concat (package-desc-full-name pkg-desc) + ".signed") + package-user-dir) + nil 'silent) + ;; Update the old pkg-desc which will be shown on the description buffer. + (setf (package-desc-signed pkg-desc) t) + ;; Update the new (activated) pkg-desc as well. + (setq pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist))) + (if pkg-descs + (setf (package-desc-signed (car pkg-descs)) t))))) (defvar package--initialized nil) @@ -741,16 +888,17 @@ It will move point to somewhere in the headers." "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). + (or + (let ((pkg-descs (cdr (assq package package-alist)))) + (and pkg-descs + (version-list-<= min-version + (package-desc-version (car pkg-descs))))) + ;; Also check built-in packages. + (package-built-in-p package min-version))) + +(defun package-compute-transaction (packages requirements) + "Return a list of packages to be installed, including PACKAGES. +PACKAGES should be a list of `package-desc'. REQUIREMENTS should be a list of additional requirements; each element in this list should have the form (PACKAGE VERSION-LIST), @@ -761,45 +909,65 @@ 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." + ;; FIXME: We really should use backtracking to explore the whole + ;; search space (e.g. if foo require bar-1.3, and bar-1.4 requires toto-1.1 + ;; whereas bar-1.3 requires toto-1.0 and the user has put a hold on toto-1.0: + ;; the current code might fail to see that it could install foo by using the + ;; older bar-1.3). (dolist (elt requirements) (let* ((next-pkg (car elt)) - (next-version (cadr elt))) - (unless (package-installed-p next-pkg next-version) + (next-version (cadr elt)) + (already ())) + (dolist (pkg packages) + (if (eq next-pkg (package-desc-name pkg)) + (setq already pkg))) + (cond + (already + (if (version-list-< next-version (package-desc-version already)) + ;; Move to front, so it gets installed early enough (bug#14082). + (setq packages (cons already (delq already packages))) + (error "Need package `%s-%s', but only %s is available" + next-pkg (package-version-join next-version) + (package-version-join (package-desc-version already))))) + + ((package-installed-p next-pkg next-version) nil) + + (t ;; 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, \ + (let ((pkg-descs (cdr (assq next-pkg package-archive-contents))) + (found nil) + (problem nil)) + (while (and pkg-descs (not found)) + (let* ((pkg-desc (pop pkg-descs)) + (version (package-desc-version pkg-desc)) + (disabled (package-disabled-p next-pkg version))) + (cond + ((version-list-< version next-version) + (error + "Need package `%s-%s', but only %s is available" + next-pkg (package-version-join next-version) + (package-version-join version))) + (disabled + (unless problem + (setq problem + (if (stringp disabled) + (format "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) + next-pkg disabled + (package-version-join next-version)) + (format "Required package '%s' is disabled" + next-pkg))))) + (t (setq found pkg-desc))))) + (unless found + (if problem + (error problem) + (error "Package `%s-%s' is unavailable" + next-pkg (package-version-join next-version)))) + (setq packages + (package-compute-transaction (cons found packages) + (package-desc-reqs found)))))))) + packages) (defun package-read-from-string (str) "Read a Lisp expression from STR. @@ -843,66 +1011,75 @@ 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)) + (let* ((contents-file (format "archives/%s/archive-contents" archive)) + (contents (package--read-archive-file contents-file))) + (when contents (dolist (package contents) (package--add-to-archive-contents package archive))))) +;; Package descriptor objects used inside the "archive-contents" file. +;; Changing this defstruct implies changing the format of the +;; "archive-contents" files. +(cl-defstruct (package--ac-desc + (:constructor package-make-ac-desc (version reqs summary kind extras)) + (:copier nil) + (:type vector)) + version reqs summary kind extras) + (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). +PACKAGE should have the form (NAME . PACKAGE--AC-DESC). +Also, add the originating archive to the `package-desc' structure." + (let* ((name (car package)) + (version (package--ac-desc-version (cdr package))) + (pkg-desc + (package-desc-create + :name name + :version version + :reqs (package--ac-desc-reqs (cdr package)) + :summary (package--ac-desc-summary (cdr package)) + :kind (package--ac-desc-kind (cdr package)) + :archive archive + :extras (and (> (length (cdr package)) 4) + ;; Older archive-contents files have only 4 + ;; elements here. + (package--ac-desc-extras (cdr package))))) + (existing-packages (assq name package-archive-contents)) + (pinned-to-archive (assoc name package-pinned-packages))) + (cond + ;; Skip entirely if pinned to another archive or already installed. + ((or (and pinned-to-archive + (not (equal (cdr pinned-to-archive) archive))) + (let ((bi (assq name package--builtin-versions))) + (and bi (version-list-= version (cdr bi)))) + (let ((ins (cdr (assq name package-alist)))) + (and ins (version-list-= version + (package-desc-version (car ins)))))) + nil) + ((not existing-packages) + (push (list name pkg-desc) package-archive-contents)) + (t + (while + (if (and (cdr existing-packages) + (version-list-< + version (package-desc-version (cadr existing-packages)))) + (setq existing-packages (cdr existing-packages)) + (push pkg-desc (cdr existing-packages)) + nil)))))) + +(defun package-download-transaction (packages) + "Download and install all the packages in PACKAGES. +PACKAGES should be a list of package-desc. This function assumes that all package requirements in -PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed +PACKAGES are satisfied, i.e. that PACKAGES 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))))) + (mapc #'package-install-from-archive packages)) ;;;###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." +(defun package-install (pkg) + "Install the package PKG. +PKG can be a package-desc or the package name of one the available packages +in an archive in `package-archives'. Interactively, prompt for its name." (interactive (progn ;; Initialize the package system to get the list of package @@ -912,19 +1089,16 @@ archive in `package-archives'. Interactively, prompt for NAME." (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)))))) + "Install package: " + (mapcar (lambda (elt) (symbol-name (car elt))) + package-archive-contents) + nil t))))) + (package-download-transaction + (if (package-desc-p pkg) + (package-compute-transaction (list pkg) + (package-desc-reqs pkg)) + (package-compute-transaction () + (list (list pkg)))))) (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. @@ -938,25 +1112,34 @@ Otherwise return nil." 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] +(declare-function lm-homepage "lisp-mnt" (&optional file)) + +(defun package--prepare-dependencies (deps) + "Turn DEPS into an acceptable list of dependencies. + +Any parts missing a version string get a default version string +of \"0\" (meaning any version) and an appropriate level of lists +is wrapped around any parts requiring it." + (cond + ((not (listp deps)) + (error "Invalid requirement specifier: %S" deps)) + (t (mapcar (lambda (dep) + (cond + ((symbolp dep) `(,dep "0")) + ((stringp dep) + (error "Invalid requirement specifier: %S" dep)) + (t dep))) + deps)))) -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. +(defun package-buffer-info () + "Return a `package-desc' describing the package in the current buffer. 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")) + (error "Package lacks a file header")) (let ((file-name (match-string-no-properties 1)) (desc (match-string-no-properties 2)) (start (line-beginning-position))) @@ -968,104 +1151,68 @@ boundaries." (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))) + (homepage (lm-homepage))) (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) + (package-desc-from-define + file-name pkg-version desc + (if requires-str + (package--prepare-dependencies + (package-read-from-string requires-str))) + :kind 'single + :url homepage)))) + +(declare-function tar-get-file-descriptor "tar-mode" (file)) +(declare-function tar--extract "tar-mode" (descriptor)) + +(defun package-tar-file-info () "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))))) +The return result is a `package-desc'." + (cl-assert (derived-mode-p 'tar-mode)) + (let* ((dir-name (file-name-directory + (tar-header-name (car tar-parse-info)))) + (desc-file (package--description-file dir-name)) + (tar-desc (tar-get-file-descriptor (concat dir-name desc-file)))) + (unless tar-desc + (error "No package descriptor file found")) + (with-current-buffer (tar--extract tar-desc) + (goto-char (point-min)) + (unwind-protect + (let* ((pkg-def-parsed (read (current-buffer))) + (pkg-desc + (if (not (eq (car pkg-def-parsed) 'define-package)) + (error "Can't find define-package in %s" + (tar-header-name tar-desc)) + (apply #'package-desc-from-define + (append (cdr pkg-def-parsed)))))) + (setf (package-desc-kind pkg-desc) 'tar) + pkg-desc) + (kill-buffer (current-buffer)))))) + ;;;###autoload -(defun package-install-from-buffer (pkg-info type) +(defun package-install-from-buffer () "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))))) +The current buffer is assumed to be a single .el or .tar file that follows the +packaging guidelines; see info node `(elisp)Packaging'. +Downloads and installs required packages as needed." + (interactive) + (let ((pkg-desc (if (derived-mode-p 'tar-mode) + (package-tar-file-info) + (package-buffer-info)))) + ;; Download and install the dependencies. + (let* ((requires (package-desc-reqs pkg-desc)) + (transaction (package-compute-transaction nil requires))) + (package-download-transaction transaction)) + ;; Install the package itself. + (package-unpack pkg-desc) + pkg-desc)) ;;;###autoload (defun package-install-file (file) @@ -1074,45 +1221,85 @@ 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) + (when (string-match "\\.tar\\'" file) (tar-mode)) + (package-install-from-buffer))) + +(defun package-delete (pkg-desc) + (let ((dir (package-desc-dir pkg-desc))) + (if (not (string-prefix-p (file-name-as-directory + (expand-file-name package-user-dir)) + (expand-file-name dir))) + ;; Don't delete "system" packages. + (error "Package `%s' is a system package, not deleting" + (package-desc-full-name pkg-desc)) + (delete-directory dir t t) + ;; Remove NAME-VERSION.signed file. + (let ((signed-file (concat dir ".signed"))) + (if (file-exists-p signed-file) + (delete-file signed-file))) + ;; Update package-alist. + (let* ((name (package-desc-name pkg-desc)) + (pkgs (assq name package-alist))) + (delete pkg-desc pkgs) + (unless (cdr pkgs) + (setq package-alist (delq pkgs package-alist)))) + (message "Package `%s' deleted." (package-desc-full-name pkg-desc))))) + +(defun package-archive-base (desc) "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)))) + (cdr (assoc (package-desc-archive desc) 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))) + (let ((dir (expand-file-name (format "archives/%s" (car archive)) + package-user-dir)) + (sig-file (concat file ".sig")) + good-signatures) (package--with-work-buffer (cdr archive) file + ;; Check signature of archive-contents, if desired. + (if (and package-check-signature + (not (member archive package-unsigned-archives))) + (if (package--archive-file-exists-p (cdr archive) sig-file) + (setq good-signatures (package--check-signature (cdr archive) + file)) + (unless (eq package-check-signature 'allow-unsigned) + (error "Unsigned archive `%s'" + (car archive))))) ;; 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)))))) + (let ((version-control 'never) + (require-final-newline nil)) + (save-buffer)))) + (when good-signatures + ;; Write out good signatures into archive-contents.signed file. + (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") + nil + (expand-file-name (concat file ".signed") dir) + nil 'silent)))) + +(declare-function epg-check-configuration "epg-config" + (config &optional minimum-version)) +(declare-function epg-configuration "epg-config" ()) +(declare-function epg-import-keys-from-file "epg" (context keys)) + +;;;###autoload +(defun package-import-keyring (&optional file) + "Import keys from FILE." + (interactive "fFile: ") + (setq file (expand-file-name file)) + (let ((context (epg-make-context 'OpenPGP)) + (homedir (expand-file-name "gnupg" package-user-dir))) + (make-directory homedir t) + (epg-context-set-home-directory context homedir) + (message "Importing %s..." (file-name-nondirectory file)) + (epg-import-keys-from-file context file) + (message "Importing %s...done" (file-name-nondirectory file)))) ;;;###autoload (defun package-refresh-contents () @@ -1120,8 +1307,17 @@ similar to an entry in `package-alist'. Save the cached copy to This informs Emacs about the latest versions of all packages, and makes them available for download." (interactive) + ;; FIXME: Do it asynchronously. (unless (file-exists-p package-user-dir) (make-directory package-user-dir t)) + (let ((default-keyring (expand-file-name "package-keyring.gpg" + data-directory))) + (if (file-exists-p default-keyring) + (condition-case-unless-debug error + (progn + (epg-check-configuration (epg-configuration)) + (package-import-keyring default-keyring)) + (error (message "Cannot import default keyring: %S" (cdr error)))))) (dolist (archive package-archives) (condition-case-unless-debug nil (package--download-one-archive archive "archive-contents") @@ -1135,13 +1331,12 @@ makes them available for download." 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) + (setq package-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))))) + (package-activate (car elt)))) (setq package--initialized t)) @@ -1151,26 +1346,25 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (defun describe-package (package) "Display the full documentation of PACKAGE (a symbol)." (interactive - (let* ((guess (function-called-at-point)) - packages val) + (let* ((guess (function-called-at-point))) (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))) + (let ((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)) + (let ((val + (completing-read (if guess + (format "Describe package (default %s): " + guess) + "Describe package: ") + packages nil t nil nil guess))) + (list (intern val)))))) + (if (not (or (package-desc-p package) (and package (symbolp package)))) (message "No package specified") (help-setup-xref (list #'describe-package package) (called-interactively-p 'interactive)) @@ -1178,73 +1372,73 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (with-current-buffer standard-output (describe-package-1 package))))) -(defun describe-package-1 (package) +(defun describe-package-1 (pkg) (require 'lisp-mnt) - (let ((package-name (symbol-name package)) - (built-in (assq package package--builtins)) - desc pkg-dir reqs version installable archive) - (prin1 package) + (let* ((desc (or + (if (package-desc-p pkg) pkg) + (cadr (assq pkg package-alist)) + (let ((built-in (assq pkg package--builtins))) + (if built-in + (package--from-builtin built-in) + (cadr (assq pkg package-archive-contents)))))) + (name (if desc (package-desc-name desc) pkg)) + (pkg-dir (if desc (package-desc-dir desc))) + (reqs (if desc (package-desc-reqs desc))) + (version (if desc (package-desc-version desc))) + (archive (if desc (package-desc-archive desc))) + (extras (and desc (package-desc-extras desc))) + (homepage (cdr (assoc :url extras))) + (keywords (if desc (package-desc--keywords desc))) + (built-in (eq pkg-dir 'builtin)) + (installable (and archive (not built-in))) + (status (if desc (package-desc-status desc) "orphan")) + (signed (if desc (package-desc-signed desc)))) + (prin1 name) (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)) - archive (aref desc (- (length desc) 1)) - 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"))) + (princ (if (memq (aref status 0) '(?a ?e ?i ?o ?u)) "an " "a ")) + (princ status) + (princ " package.\n\n") (insert " " (propertize "Status" 'font-lock-face 'bold) ": ") - (cond (pkg-dir - (insert (propertize "Installed" + (cond (built-in + (insert (propertize (capitalize status) + 'font-lock-face 'font-lock-builtin-face) + ".")) + (pkg-dir + (insert (propertize (if (equal status "unsigned") + "Installed" + (capitalize status)) ;FIXME: Why comment-face? '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-insert-xref-button (abbreviate-file-name + (file-name-as-directory pkg-dir)) 'help-package-def pkg-dir) - (if built-in + (if (and (package-built-in-p name) + (not (package-built-in-p name version))) (insert "',\n shadowing a " (propertize "built-in package" - 'font-lock-face 'font-lock-builtin-face) - ".") - (insert "'."))) + 'font-lock-face 'font-lock-builtin-face)) + (insert "'")) + (if signed + (insert ".") + (insert " (unsigned)."))) (installable - (if built-in - (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face) - " Alternate version available") - (insert "Available")) - (insert " from " archive) + (insert (capitalize status)) + (insert " from " (format "%s" archive)) (insert " -- ") - (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."))) + (package-make-button + "Install" + 'action 'package-install-button-action + 'package-desc desc)) + (t (insert (capitalize status) "."))) (insert "\n") - (and version (> (length version) 0) + (insert " " (propertize "Archive" 'font-lock-face 'bold) + ": " (or archive "n/a") "\n") + (and version (insert " " - (propertize "Version" 'font-lock-face 'bold) ": " version "\n")) + (propertize "Version" 'font-lock-face 'bold) ": " + (package-version-join version) "\n")) (setq reqs (if desc (package-desc-reqs desc))) (when reqs @@ -1264,11 +1458,50 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (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 desc (package-desc-summary desc)) "\n") + (when homepage + (insert " " (propertize "Homepage" 'font-lock-face 'bold) ": ") + (help-insert-xref-button homepage 'help-url homepage) + (insert "\n")) + (when keywords + (insert " " (propertize "Keywords" 'font-lock-face 'bold) ": ") + (dolist (k keywords) + (package-make-button + k + 'package-keyword k + 'action 'package-keyword-button-action) + (insert " ")) + (insert "\n")) + (let* ((all-pkgs (append (cdr (assq name package-alist)) + (cdr (assq name package-archive-contents)) + (let ((bi (assq name package--builtins))) + (if bi (list (package--from-builtin bi)))))) + (other-pkgs (delete desc all-pkgs))) + (when other-pkgs + (insert " " (propertize "Other versions" 'font-lock-face 'bold) ": " + (mapconcat + (lambda (opkg) + (let* ((ov (package-desc-version opkg)) + (dir (package-desc-dir opkg)) + (from (or (package-desc-archive opkg) + (if (stringp dir) "installed" dir)))) + (if (not ov) (format "%s" from) + (format "%s (%s)" + (make-text-button (package-version-join ov) nil + 'face 'link + 'follow-link t + 'action + (lambda (_button) + (describe-package opkg))) + from)))) + other-pkgs ", ") + ".\n"))) + + (insert "\n") (if built-in ;; For built-in packages, insert the commentary. - (let ((fn (locate-file (concat package-name ".el") load-path + (let ((fn (locate-file (format "%s.el" name) load-path load-file-rep-suffixes)) (opoint (point))) (insert (or (lm-commentary fn) "")) @@ -1278,20 +1511,23 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (replace-match "")) (while (re-search-forward "^\\(;+ ?\\)" nil t) (replace-match "")))) - (let ((readme (expand-file-name (concat package-name "-readme.txt") + (let ((readme (expand-file-name (format "%s-readme.txt" name) 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) + (save-excursion + (package--with-work-buffer + (package-archive-base desc) + (format "%s-readme.txt" name) + (setq buffer-file-name + (expand-file-name readme package-user-dir)) + (let ((version-control 'never) + (require-final-newline t)) + (save-buffer)) + (setq readme-string (buffer-string)) + t)) (error nil)) (insert readme-string)) ((file-readable-p readme) @@ -1299,12 +1535,27 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (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) + (let ((pkg-desc (button-get button 'package-desc))) + (when (y-or-n-p (format "Install package `%s'? " + (package-desc-full-name pkg-desc))) + (package-install pkg-desc) (revert-buffer nil t) (goto-char (point-min))))) +(defun package-keyword-button-action (button) + (let ((pkg-keyword (button-get button 'package-keyword))) + (package-show-package-list t (list pkg-keyword)))) + +(defun package-make-button (text &rest props) + (let ((button-text (if (display-graphic-p) text (concat "[" text "]"))) + (button-face (if (display-graphic-p) + '(:box (:line-width 2 :color "dark grey") + :background "light grey" + :foreground "black") + 'link))) + (apply 'insert-text-button button-text 'face button-face 'follow-link t + props))) + ;;;; Package menu mode. @@ -1319,6 +1570,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (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 "f" 'package-menu-filter) (define-key map "~" 'package-menu-mark-obsolete-for-deletion) (define-key map "x" 'package-menu-execute) (define-key map "h" 'package-menu-quick-help) @@ -1351,6 +1603,9 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." '(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 [mf] + '(menu-item "Filter Package List..." package-menu-filter + :help "Filter package selection (q to go back)")) (define-key menu-map [mg] '(menu-item "Update Package List" revert-buffer :help "Update the list of packages")) @@ -1382,97 +1637,209 @@ If optional arg NO-ACTIVATE is non-nil, don't activate 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-format + `[("Package" 18 package-menu--name-predicate) + ("Version" 12 nil) + ("Status" 10 package-menu--status-predicate) + ,@(if (cdr package-archives) + '(("Archive" 10 package-menu--archive-predicate))) + ("Description" 0 nil)]) (setq tabulated-list-padding 2) (setq tabulated-list-sort-key (cons "Status" nil)) + (add-hook 'tabulated-list-revert-hook 'package-menu--refresh nil t) (tabulated-list-init-header)) -(defmacro package--push (package desc status listname) +(defmacro package--push (pkg-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). +package PKG-DESC, add one. The alist is keyed with PKG-DESC." + `(unless (assoc ,pkg-desc ,listname) + ;; FIXME: Should we move status into pkg-desc? + (push (cons ,pkg-desc ,status) ,listname))) + +(defvar package-list-unversioned nil + "If non-nil include packages that don't have a version in `list-package'.") + +(defun package-desc-status (pkg-desc) + (let* ((name (package-desc-name pkg-desc)) + (dir (package-desc-dir pkg-desc)) + (lle (assq name package-load-list)) + (held (cadr lle)) + (version (package-desc-version pkg-desc)) + (signed (package-desc-signed pkg-desc))) + (cond + ((eq dir 'builtin) "built-in") + ((and lle (null held)) "disabled") + ((stringp held) + (let ((hv (if (stringp held) (version-to-list held)))) + (cond + ((version-list-= version hv) "held") + ((version-list-< version hv) "obsolete") + (t "disabled")))) + ((package-built-in-p name version) "obsolete") + (dir ;One of the installed packages. + (cond + ((not (file-exists-p (package-desc-dir pkg-desc))) "deleted") + ((eq pkg-desc (cadr (assq name package-alist))) (if signed + "installed" + "unsigned")) + (t "obsolete"))) + (t + (let* ((ins (cadr (assq name package-alist))) + (ins-v (if ins (package-desc-version ins)))) + (cond + ((or (null ins) (version-list-< ins-v version)) + (if (memq name package-menu--new-package-list) + "new" "available")) + ((version-list-< version ins-v) "obsolete") + ((version-list-= version ins-v) (if signed + "installed" + "unsigned")))))))) + +(defun package-menu--refresh (&optional packages keywords) + "Re-populate the `tabulated-list-entries'. +PACKAGES should be nil or t, which means to display all known packages. +KEYWORDS should be nil or a list of keywords." + ;; Construct list of (PKG-DESC . STATUS). + (unless packages (setq packages t)) (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))) + (dolist (pkg (cdr elt)) + (when (package--has-keyword-p pkg keywords) + (package--push pkg (package-desc-status pkg) info-list))))) ;; Built-in packages: (dolist (elt package--builtins) (setq name (car elt)) (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. + (package--has-keyword-p (package--from-builtin elt) keywords) + (or package-list-unversioned + (package--bi-desc-version (cdr elt))) (or (eq packages t) (memq name packages))) - (package--push name (cdr elt) "built-in" info-list))) + (package--push (package--from-builtin 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)))) + (dolist (pkg (cdr elt)) + ;; Hide obsolete packages. + (when (and (not (package-installed-p (package-desc-name pkg) + (package-desc-version pkg))) + (package--has-keyword-p pkg keywords)) + (package--push pkg (package-desc-status pkg) info-list))))) ;; Print the result. - (setq tabulated-list-entries (mapcar 'package-menu--print-info info-list)) - (tabulated-list-print remember-pos))) + (setq tabulated-list-entries + (mapcar #'package-menu--print-info info-list)))) + +(defun package-all-keywords () + "Collect all package keywords" + (let (keywords) + (package--mapc (lambda (desc) + (let* ((desc-keywords (and desc (package-desc--keywords desc)))) + (setq keywords (append keywords desc-keywords))))) + keywords)) + +(defun package--mapc (function &optional packages) + "Call FUNCTION for all known PACKAGES. +PACKAGES can be nil or t, which means to display all known +packages, or a list of packages. + +Built-in packages are converted with `package--from-builtin'." + (unless packages (setq packages t)) + (let (name) + ;; Installed packages: + (dolist (elt package-alist) + (setq name (car elt)) + (when (or (eq packages t) (memq name packages)) + (mapc function (cdr elt)))) + + ;; Built-in packages: + (dolist (elt package--builtins) + (setq name (car elt)) + (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. + (or package-list-unversioned + (package--bi-desc-version (cdr elt))) + (or (eq packages t) (memq name packages))) + (funcall function (package--from-builtin elt)))) + + ;; Available and disabled packages: + (dolist (elt package-archive-contents) + (setq name (car elt)) + (when (or (eq packages t) (memq name packages)) + (dolist (pkg (cdr elt)) + ;; Hide obsolete packages. + (unless (package-installed-p (package-desc-name pkg) + (package-desc-version pkg)) + (funcall function pkg))))))) + +(defun package--has-keyword-p (desc &optional keywords) + "Test if package DESC has any of the given KEYWORDS. +When none are given, the package matches." + (if keywords + (let* ((desc-keywords (and desc (package-desc--keywords desc))) + found) + (dolist (k keywords) + (when (and (not found) + (member k desc-keywords)) + (setq found t))) + found) + t)) + +(defun package-menu--generate (remember-pos packages &optional keywords) + "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. + +With KEYWORDS given, only packages with those keywords are +shown." + (package-menu--refresh packages keywords) + (setf (car (aref tabulated-list-format 0)) + (if keywords + (let ((filters (mapconcat 'identity keywords ","))) + (concat "Package[" filters "]")) + "Package")) + (if keywords + (define-key package-menu-mode-map "q" 'package-show-package-list) + (define-key package-menu-mode-map "q" 'quit-window)) + (tabulated-list-init-header) + (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))))) +PKG has the form (PKG-DESC . STATUS). +Return (PKG-DESC [NAME VERSION STATUS DOC])." + (let* ((pkg-desc (car pkg)) + (status (cdr pkg)) + (face (pcase status + (`"built-in" 'font-lock-builtin-face) + (`"available" 'default) + (`"new" 'bold) + (`"held" 'font-lock-constant-face) + (`"disabled" 'font-lock-warning-face) + (`"installed" 'font-lock-comment-face) + (`"unsigned" 'font-lock-warning-face) + (_ 'font-lock-warning-face)))) ; obsolete. + (list pkg-desc + `[,(list (symbol-name (package-desc-name pkg-desc)) + 'face 'link + 'follow-link t + 'package-desc pkg-desc + 'action 'package-menu-describe-package) + ,(propertize (package-version-join + (package-desc-version pkg-desc)) + 'font-lock-face face) + ,(propertize status 'font-lock-face face) + ,@(if (cdr package-archives) + (list (propertize (or (package-desc-archive pkg-desc) "") + 'font-lock-face face))) + ,(propertize (package-desc-summary pkg-desc) + 'font-lock-face face)]))) (defun package-menu-refresh () "Download the Emacs Lisp package archive. @@ -1480,7 +1847,7 @@ 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")) + (user-error "The current buffer is not a Package Menu")) (package-refresh-contents) (package-menu--generate t t)) @@ -1488,16 +1855,17 @@ This fetches the contents of each archive specified in "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)))) + (let ((pkg-desc (if button (button-get button 'package-desc) + (tabulated-list-get-id)))) + (if pkg-desc + (describe-package pkg-desc) + (user-error "No package here")))) ;; 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")) + (if (member (package-menu-get-status) '("installed" "obsolete" "unsigned")) (tabulated-list-put-tag "D" t) (forward-line))) @@ -1538,8 +1906,8 @@ If optional arg BUTTON is non-nil, describe its associated package." '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)))) + (let* ((id (tabulated-list-get-id)) + (entry (and id (assq id tabulated-list-entries)))) (if entry (aref (cadr entry) 2) ""))) @@ -1548,18 +1916,20 @@ If optional arg BUTTON is non-nil, describe its associated package." (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)) + ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC]) + (let ((pkg-desc (car entry)) (status (aref (cadr entry) 2))) - (cond ((equal status "installed") - (push pkg installed)) + (cond ((member status '("installed" "unsigned")) + (push pkg-desc 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))) + (push (cons (package-desc-name pkg-desc) pkg-desc) + available))))) + ;; Loop through list of installed packages, finding upgrades. + (dolist (pkg-desc installed) + (let ((avail-pkg (assq (package-desc-name pkg-desc) available))) (and avail-pkg - (version-list-< (cdr pkg) (cdr avail-pkg)) + (version-list-< (package-desc-version pkg-desc) + (package-desc-version (cdr avail-pkg))) (push avail-pkg upgrades)))) upgrades)) @@ -1579,11 +1949,11 @@ call will upgrade the package." (save-excursion (goto-char (point-min)) (while (not (eobp)) - (let* ((pkg (tabulated-list-get-id)) - (upgrade (assq (car pkg) upgrades))) + (let* ((pkg-desc (tabulated-list-get-id)) + (upgrade (cdr (assq (package-desc-name pkg-desc) upgrades)))) (cond ((null upgrade) (forward-line 1)) - ((equal pkg upgrade) + ((equal pkg-desc upgrade) (package-menu-mark-install)) (t (package-menu-mark-delete)))))) @@ -1599,30 +1969,30 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (interactive) (unless (derived-mode-p 'package-menu-mode) (error "The current buffer is not in Package Menu mode")) - (let (install-list delete-list cmd id) + (let (install-list delete-list cmd pkg-desc) (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)) + ;; This is the key PKG-DESC. + (setq pkg-desc (tabulated-list-get-id)) (cond ((eq cmd ?D) - (push (cons (symbol-name (car id)) - (package-version-join (cdr id))) - delete-list)) + (push pkg-desc delete-list)) ((eq cmd ?I) - (push (car id) install-list)))) + (push pkg-desc install-list)))) (forward-line))) (when install-list (if (or noquery (yes-or-no-p - (if (= (length install-list) 1) - (format "Install package `%s'? " (car install-list)) - (format "Install these %d packages (%s)? " - (length install-list) - (mapconcat 'symbol-name install-list ", "))))) + (if (= (length install-list) 1) + (format "Install package `%s'? " + (package-desc-full-name (car install-list))) + (format "Install these %d packages (%s)? " + (length install-list) + (mapconcat #'package-desc-full-name + install-list ", "))))) (mapc 'package-install install-list))) ;; Delete packages, prompting if necessary. (when delete-list @@ -1630,24 +2000,17 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." noquery (yes-or-no-p (if (= (length delete-list) 1) - (format "Delete package `%s-%s'? " - (caar delete-list) - (cdr (car delete-list))) + (format "Delete package `%s'? " + (package-desc-full-name (car delete-list))) (format "Delete these %d packages (%s)? " (length delete-list) - (mapconcat (lambda (elt) - (concat (car elt) "-" (cdr elt))) - delete-list - ", "))))) + (mapconcat #'package-desc-full-name + delete-list ", "))))) (dolist (elt delete-list) (condition-case-unless-debug err - (package-delete (car elt) (cdr elt)) + (package-delete 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.")))) @@ -1670,6 +2033,8 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." ((string= sB "available") nil) ((string= sA "installed") t) ((string= sB "installed") nil) + ((string= sA "unsigned") t) + ((string= sB "unsigned") nil) ((string= sA "held") t) ((string= sB "held") nil) ((string= sA "built-in") t) @@ -1686,8 +2051,12 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (string< dA dB)))) (defun package-menu--name-predicate (A B) - (string< (symbol-name (caar A)) - (symbol-name (caar B)))) + (string< (symbol-name (package-desc-name (car A))) + (symbol-name (package-desc-name (car B))))) + +(defun package-menu--archive-predicate (A B) + (string< (or (package-desc-archive (car A)) "") + (or (package-desc-archive (car B)) ""))) ;;;###autoload (defun list-packages (&optional no-fetch) @@ -1735,18 +2104,31 @@ The list is displayed in a buffer named `*Packages*'." (defalias 'package-list-packages 'list-packages) ;; Used in finder.el -(defun package-show-package-list (packages) +(defun package-show-package-list (&optional packages keywords) "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)." +names in PACKAGES (which should be a list of symbols). + +When KEYWORDS are given, only packages with those KEYWORDS are +shown." + (interactive) (require 'finder-inf nil t) (let ((buf (get-buffer-create "*Packages*"))) (with-current-buffer buf (package-menu-mode) - (package-menu--generate nil packages)) + (package-menu--generate nil packages keywords)) (switch-to-buffer buf))) +;; package-menu--generate rebinds "q" on the fly, so we have to +;; hard-code the binding in the doc-string here. +(defun package-menu-filter (keyword) + "Filter the *Packages* buffer. +Show only those items that relate to the specified KEYWORD. +To restore the full package list, type `q'." + (interactive (list (completing-read "Keyword: " (package-all-keywords)))) + (package-show-package-list t (list keyword))) + (defun package-list-packages-no-fetch () "Display a list of packages. Does not fetch the updated list of packages before displaying. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index e000c343721..2cdb7b4987e 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -1,6 +1,6 @@ ;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*- -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2010-2014 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: @@ -353,23 +353,34 @@ MATCH is the pattern that needs to be matched, of the form: (symbolp . numberp) (symbolp . consp) (symbolp . arrayp) + (symbolp . vectorp) (symbolp . stringp) (symbolp . byte-code-function-p) (integerp . consp) (integerp . arrayp) + (integerp . vectorp) (integerp . stringp) (integerp . byte-code-function-p) (numberp . consp) (numberp . arrayp) + (numberp . vectorp) (numberp . stringp) (numberp . byte-code-function-p) (consp . arrayp) + (consp . vectorp) (consp . stringp) (consp . byte-code-function-p) - (arrayp . stringp) (arrayp . byte-code-function-p) + (vectorp . byte-code-function-p) + (stringp . vectorp) (stringp . byte-code-function-p))) +(defun pcase--mutually-exclusive-p (pred1 pred2) + (or (member (cons pred1 pred2) + pcase-mutually-exclusive-predicates) + (member (cons pred2 pred1) + pcase-mutually-exclusive-predicates))) + (defun pcase--split-match (sym splitter match) (cond ((eq (car match) 'match) @@ -433,10 +444,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; A QPattern but not for a cons, can only go to the `else' side. ((eq (car-safe pat) '\`) '(:pcase--fail . nil)) ((and (eq (car-safe pat) 'pred) - (or (member (cons 'consp (cadr pat)) - pcase-mutually-exclusive-predicates) - (member (cons (cadr pat) 'consp) - pcase-mutually-exclusive-predicates))) + (pcase--mutually-exclusive-p #'consp (cadr pat))) '(:pcase--fail . nil)))) (defun pcase--split-equal (elem pat) @@ -453,9 +461,10 @@ MATCH is the pattern that needs to be matched, of the form: ((and (eq (car-safe pat) 'pred) (symbolp (cadr pat)) (get (cadr pat) 'side-effect-free)) - (if (funcall (cadr pat) elem) - '(:pcase--succeed . nil) - '(:pcase--fail . nil))))) + (ignore-errors + (if (funcall (cadr pat) elem) + '(:pcase--succeed . nil) + '(:pcase--fail . nil)))))) (defun pcase--split-member (elems pat) ;; Based on pcase--split-equal. @@ -476,24 +485,35 @@ MATCH is the pattern that needs to be matched, of the form: ((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)) + (ignore-errors + (let ((p (cadr pat)) (all t)) + (dolist (elem elems) + (unless (funcall p elem) (setq all nil))) + all))) '(: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'. +(defun pcase--split-pred (vars upat pat) (let (test) (cond - ((equal upat pat) '(:pcase--succeed . :pcase--fail)) + ((and (equal upat pat) + ;; For predicates like (pred (> a)), two such predicates may + ;; actually refer to different variables `a'. + (or (and (eq 'pred (car upat)) (symbolp (cadr upat))) + ;; FIXME: `vars' gives us the environment in which `upat' will + ;; run, but we don't have the environment in which `pat' will + ;; run, so we can't do a reliable verification. But let's try + ;; and catch at least the easy cases such as (bug#14773). + (not (pcase--fgrep (mapcar #'car vars) (cadr upat))))) + '(: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))) + (let ((otherpred + (cond ((eq 'pred (car-safe pat)) (cadr pat)) + ((not (eq '\` (car-safe pat))) nil) + ((consp (cadr pat)) #'consp) + ((vectorp (cadr pat)) #'vectorp) + ((byte-code-function-p (cadr pat)) + #'byte-code-function-p)))) + (pcase--mutually-exclusive-p (cadr upat) otherpred))) '(:pcase--fail . nil)) ((and (eq 'pred (car upat)) (eq '\` (car-safe pat)) @@ -589,7 +609,7 @@ Otherwise, it defers to REST which is a list of branches of the form (if (eq (car upat) 'pred) (pcase--mark-used sym)) (let* ((splitrest (pcase--split-rest - sym (lambda (pat) (pcase--split-pred upat pat)) rest)) + sym (lambda (pat) (pcase--split-pred vars upat pat)) rest)) (then-rest (car splitrest)) (else-rest (cdr splitrest))) (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) @@ -652,11 +672,15 @@ Otherwise, it defers to REST which is a list of branches of the form (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))))) + (unless (if (pcase--self-quoting-p alt) + (progn + (unless (or (symbolp alt) (integerp alt)) + (setq memq-fine nil)) + t) + (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. @@ -739,14 +763,14 @@ Otherwise, it defers to REST which is a list of branches of the form ;; `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))))) + ,@(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))) + (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)) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index b7e553272f2..0e4139e1aeb 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -1,6 +1,6 @@ ;;; pp.el --- pretty printer for Emacs Lisp -;; Copyright (C) 1989, 1993, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1993, 2001-2014 Free Software Foundation, Inc. ;; Author: Randal Schwartz <merlyn@stonehenge.com> ;; Keywords: lisp @@ -127,8 +127,7 @@ after OUT-BUFFER-NAME." "Evaluate EXPRESSION and pretty-print its value. Also add the value to the front of the list in the variable `values'." (interactive - (list (read-from-minibuffer "Eval: " nil read-expression-map t - 'read-expression-history))) + (list (read--expression "Eval: "))) (message "Evaluating...") (setq values (cons (eval expression) values)) (pp-display-expression (car values) "*Pp Eval Output*")) @@ -137,8 +136,7 @@ Also add the value to the front of the list in the variable `values'." (defun pp-macroexpand-expression (expression) "Macroexpand EXPRESSION and pretty-print its value." (interactive - (list (read-from-minibuffer "Macroexpand: " nil read-expression-map t - 'read-expression-history))) + (list (read--expression "Macroexpand: "))) (pp-display-expression (macroexpand expression) "*Pp Macroexpand Output*")) (defun pp-last-sexp () diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 9b73bea065f..48ad575f056 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -1,6 +1,6 @@ ;;; re-builder.el --- building Regexps with visual feedback -*- lexical-binding: t -*- -;; Copyright (C) 1999-2013 Free Software Foundation, Inc. +;; Copyright (C) 1999-2014 Free Software Foundation, Inc. ;; Author: Detlev Zundel <dzu@gnu.org> ;; Keywords: matching, lisp, tools @@ -319,7 +319,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (eq 'color ;; emacs/xemacs compatibility (if (fboundp 'frame-parameter) - (frame-parameter (selected-frame) 'display-type) + (frame-parameter nil 'display-type) (if (fboundp 'frame-property) (frame-property (selected-frame) 'display-type))))) diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index de9966c0af0..b2d4f2b71dd 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -1,9 +1,9 @@ ;;; regexp-opt.el --- generate efficient regexps to match strings -;; Copyright (C) 1994-2013 Free Software Foundation, Inc. +;; Copyright (C) 1994-2014 Free Software Foundation, Inc. ;; Author: Simon Marshall <simon@gnu.org> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: strings, regexps, extensions ;; This file is part of GNU Emacs. @@ -285,7 +285,9 @@ CHARS should be a list of characters." ;; ;; Make sure a caret is not first and a dash is first or last. (if (and (string-equal charset "") (string-equal bracket "")) - (concat "[" dash caret "]") + (if (string-equal dash "") + "\\^" ; [^] is not a valid regexp + (concat "[" dash caret "]")) (concat "[" bracket charset caret dash "]")))) (provide 'regexp-opt) diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index 9514ee62485..c941bd6c1bc 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -1,6 +1,6 @@ ;;; regi.el --- REGular expression Interpreting engine -;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2014 Free Software Foundation, Inc. ;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com> ;; Maintainer: bwarsaw@cen.com diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index f2c4389e71f..3d430a6756d 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -1,8 +1,8 @@ ;;; ring.el --- handle rings of items -;; Copyright (C) 1992, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2014 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: extensions ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index e578298106d..2e513ff848b 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1,9 +1,9 @@ ;;; rx.el --- sexp notation for regular expressions -;; Copyright (C) 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 2001-2014 Free Software Foundation, Inc. ;; Author: Gerd Moellmann <gerd@gnu.org> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: strings, regexps, extensions ;; This file is part of GNU Emacs. @@ -258,7 +258,8 @@ regular expressions.") (not-at-end-of-line . ?<) (not-at-beginning-of-line . ?>) (alpha-numeric-two-byte . ?A) - (chinse-two-byte . ?C) + (chinese-two-byte . ?C) + (chinse-two-byte . ?C) ;; A typo in Emacs 21.1-24.3. (greek-two-byte . ?G) (japanese-hiragana-two-byte . ?H) (indian-two-byte . ?I) @@ -871,7 +872,7 @@ NO-GROUP non-nil means don't put shy groups around the result." REGEXPS is a non-empty sequence of forms of the sort listed below. Note that `rx' is a Lisp macro; when used in a Lisp program being - compiled, the translation is performed by the compiler. +compiled, the translation is performed by the compiler. See `rx-to-string' for how to do such a translation at run-time. The following are valid subforms of regular expressions in sexp @@ -1045,7 +1046,7 @@ CHAR `not-at-end-of-line' (\\c<) `not-at-beginning-of-line' (\\c>) `alpha-numeric-two-byte' (\\cA) - `chinse-two-byte' (\\cC) + `chinese-two-byte' (\\cC) `greek-two-byte' (\\cG) `japanese-hiragana-two-byte' (\\cH) `indian-tow-byte' (\\cI) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index b12fba17027..aba929035d1 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -1,6 +1,6 @@ ;;; shadow.el --- locate Emacs Lisp file shadowings -;; Copyright (C) 1995, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2001-2014 Free Software Foundation, Inc. ;; Author: Terry Jones <terry@santafe.edu> ;; Keywords: lisp @@ -45,7 +45,7 @@ ;; ;; emacs -batch -f list-load-path-shadows ;; -;; Thanks to Francesco Potorti` <pot@cnuce.cnr.it> for suggestions, +;; Thanks to Francesco Potortì <pot@cnuce.cnr.it> for suggestions, ;; rewritings & speedups. ;;; Code: @@ -207,102 +207,84 @@ the earlier. For example, suppose `load-path' is set to -\(\"/usr/gnu/emacs/site-lisp\" \"/usr/gnu/emacs/share/emacs/19.30/lisp\"\) +\(\"/usr/share/emacs/site-lisp\" \"/usr/share/emacs/24.3/lisp\") and that each of these directories contains a file called XXX.el. Then XXX.el in the site-lisp directory is referred to by all of: -\(require 'XXX\), \(autoload .... \"XXX\"\), \(load-library \"XXX\"\) etc. +\(require 'XXX), (autoload .... \"XXX\"), (load-library \"XXX\") etc. -The first XXX.el file prevents Emacs from seeing the second \(unless -the second is loaded explicitly via `load-file'\). +The first XXX.el file prevents Emacs from seeing the second (unless +the second is loaded explicitly via `load-file'). When not intended, such shadowings can be the source of subtle problems. For example, the above situation may have arisen because the XXX package was not distributed with versions of Emacs prior to -19.30. An Emacs maintainer downloaded XXX from elsewhere and installed +24.3. A system administrator downloaded XXX from elsewhere and installed it. Later, XXX was updated and included in the Emacs distribution. -Unless the Emacs maintainer checks for this, the new version of XXX -will be hidden behind the old \(which may no longer work with the new -Emacs version\). +Unless the system administrator checks for this, the new version of XXX +will be hidden behind the old (which may no longer work with the new +Emacs version). This function performs these checks and flags all possible shadowings. Because a .el file may exist without a corresponding .elc -\(or vice-versa\), these suffixes are essentially ignored. A file -XXX.elc in an early directory \(that does not contain XXX.el\) is +\(or vice-versa), these suffixes are essentially ignored. A file +XXX.elc in an early directory (that does not contain XXX.el) is considered to shadow a later file XXX.el, and vice-versa. Shadowings are located by calling the (non-interactive) companion function, `load-path-shadows-find'." (interactive) - (let* ((path (copy-sequence load-path)) - (tem path) - toplevs) - ;; If we can find simple.el in two places, - (dolist (tt tem) - (if (or (file-exists-p (expand-file-name "simple.el" tt)) - (file-exists-p (expand-file-name "simple.el.gz" tt))) - (setq toplevs (cons tt toplevs)))) - (if (> (length toplevs) 1) - ;; Cut off our copy of load-path right before - ;; the last directory which has simple.el in it. - ;; This avoids loads of duplications between the source dir - ;; and the dir where these files were copied by installation. - (let ((break (car toplevs))) - (setq tem path) - (while tem - (if (eq (nth 1 tem) break) - (progn - (setcdr tem nil) - (setq tem nil))) - (setq tem (cdr tem))))) - - (let* ((shadows (load-path-shadows-find path)) - (n (/ (length shadows) 2)) - (msg (format "%s Emacs Lisp load-path shadowing%s found" - (if (zerop n) "No" (concat "\n" (number-to-string n))) - (if (= n 1) " was" "s were")))) - (with-temp-buffer - (while shadows - (insert (format "%s hides %s\n" (car shadows) - (car (cdr shadows)))) - (setq shadows (cdr (cdr shadows)))) - (if stringp - (buffer-string) - (if (called-interactively-p 'interactive) - ;; We are interactive. - ;; Create the *Shadows* buffer and display shadowings there. - (let ((string (buffer-string))) - (with-current-buffer (get-buffer-create "*Shadows*") - (display-buffer (current-buffer)) - (load-path-shadows-mode) ; run after-change-major-mode-hook - (let ((inhibit-read-only t)) - (erase-buffer) - (insert string) - (insert msg "\n") - (while (re-search-backward "\\(^.*\\) hides \\(.*$\\)" - nil t) - (dotimes (i 2) - (make-button (match-beginning (1+ i)) - (match-end (1+ i)) - 'type 'load-path-shadows-find-file - 'shadow-file - (match-string (1+ i))))) - (goto-char (point-max))))) - ;; We are non-interactive, print shadows via message. - (unless (zerop n) - (message "This site has duplicate Lisp libraries with the same name. + (let* ((shadows (load-path-shadows-find load-path)) + (n (/ (length shadows) 2)) + (msg (format "%s Emacs Lisp load-path shadowing%s found" + (if (zerop n) "No" (concat "\n" (number-to-string n))) + (if (= n 1) " was" "s were")))) + (with-temp-buffer + (while shadows + (insert (format "%s hides %s\n" (car shadows) + (car (cdr shadows)))) + (setq shadows (cdr (cdr shadows)))) + (if stringp + (buffer-string) + (if (called-interactively-p 'interactive) + ;; We are interactive. + ;; Create the *Shadows* buffer and display shadowings there. + (let ((string (buffer-string))) + (with-current-buffer (get-buffer-create "*Shadows*") + (display-buffer (current-buffer)) + (load-path-shadows-mode) ; run after-change-major-mode-hook + (let ((inhibit-read-only t)) + (erase-buffer) + (insert string) + (insert msg "\n") + (while (re-search-backward "\\(^.*\\) hides \\(.*$\\)" + nil t) + (dotimes (i 2) + (make-button (match-beginning (1+ i)) + (match-end (1+ i)) + 'type 'load-path-shadows-find-file + 'shadow-file + (match-string (1+ i))))) + (goto-char (point-max))))) + ;; We are non-interactive, print shadows via message. + (unless (zerop n) + (message "This site has duplicate Lisp libraries with the same name. If a locally-installed Lisp library overrides a library in the Emacs release, that can cause trouble, and you should probably remove the locally-installed version unless you know what you are doing.\n") - (goto-char (point-min)) - ;; Mimic the previous behavior of using lots of messages. - ;; I think one single message would look better... - (while (not (eobp)) - (message "%s" (buffer-substring (line-beginning-position) - (line-end-position))) - (forward-line 1)) - (message "%s" msg)))))))) + (goto-char (point-min)) + ;; Mimic the previous behavior of using lots of messages. + ;; I think one single message would look better... + (while (not (eobp)) + (message "%s" (buffer-substring (line-beginning-position) + (line-end-position))) + (forward-line 1)) + (message "%s" msg))))))) (provide 'shadow) ;;; shadow.el ends here + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index eb3fa8f3b09..02a41cddfab 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1,6 +1,6 @@ ;;; smie.el --- Simple Minded Indentation Engine -*- lexical-binding: t -*- -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2010-2014 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: languages, lisp, internal, parsing, indentation @@ -707,13 +707,15 @@ Possible return values: ((null toklevels) (when (zerop (length token)) (condition-case err - (progn (goto-char pos) (funcall next-sexp 1) nil) + (progn (funcall next-sexp 1) nil) (scan-error - (let ((pos (nth 2 err))) + (let ((epos (nth 2 err))) + (goto-char pos) (throw 'return - (list t pos + (list t epos (buffer-substring-no-properties - pos (+ pos (if (< (point) pos) -1 1)))))))) + epos + (+ epos (if (< (point) epos) -1 1)))))))) (if (eq pos (point)) ;; We did not move, so let's abort the loop. (throw 'return (list t (point)))))) @@ -957,7 +959,7 @@ If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\" (let ((ender (funcall smie-backward-token-function))) (cond ((not (and ender (rassoc ender smie-closer-alist))) - ;; This not is one of the begin..end we know how to check. + ;; This is not one of the begin..end we know how to check. (blink-matching-check-mismatch start end)) ((not start) t) ((eq t (car (rassoc ender smie-closer-alist))) nil) @@ -1012,6 +1014,9 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'. (or (eq (char-before) last-command-event) (not (memq (char-before) smie-blink-matching-triggers))) + ;; FIXME: For octave's "switch ... case ... case" we flash + ;; `switch' at the end of the first `case' and we burp + ;; "mismatch" at the end of the second `case'. (or smie-blink-matching-inners (not (numberp (nth 2 (assoc token smie-grammar)))))) ;; The major mode might set blink-matching-check-function @@ -1021,6 +1026,93 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'. (let ((blink-matching-check-function #'smie-blink-matching-check)) (blink-matching-open)))))))) +(defvar-local smie--matching-block-data-cache nil) + +(defun smie--opener/closer-at-point () + "Return (OPENER TOKEN START END) or nil. +OPENER is non-nil if TOKEN is an opener and nil if it's a closer." + (let* ((start (point)) + ;; Move to a previous position outside of a token. + (_ (funcall smie-backward-token-function)) + ;; Move to the end of the token before point. + (btok (funcall smie-forward-token-function)) + (bend (point))) + (cond + ;; Token before point is a closer? + ((and (>= bend start) (rassoc btok smie-closer-alist)) + (funcall smie-backward-token-function) + (when (< (point) start) + (prog1 (list nil btok (point) bend) + (goto-char bend)))) + ;; Token around point is an opener? + ((and (> bend start) (assoc btok smie-closer-alist)) + (funcall smie-backward-token-function) + (when (<= (point) start) (list t btok (point) bend))) + ((<= bend start) + (let ((atok (funcall smie-forward-token-function)) + (aend (point))) + (cond + ((< aend start) nil) ;Hopefully shouldn't happen. + ;; Token after point is a closer? + ((assoc atok smie-closer-alist) + (funcall smie-backward-token-function) + (when (<= (point) start) + (list t atok (point) aend))))))))) + +(defun smie--matching-block-data (orig &rest args) + "A function suitable for `show-paren-data-function' (which see)." + (if (or (null smie-closer-alist) + (equal (cons (point) (buffer-chars-modified-tick)) + (car smie--matching-block-data-cache))) + (or (cdr smie--matching-block-data-cache) + (apply orig args)) + (setq smie--matching-block-data-cache + (list (cons (point) (buffer-chars-modified-tick)))) + (unless (nth 8 (syntax-ppss)) + (condition-case nil + (let ((here (smie--opener/closer-at-point))) + (when (and here + (or smie-blink-matching-inners + (not (numberp + (nth (if (nth 0 here) 1 2) + (assoc (nth 1 here) smie-grammar)))))) + (let ((there + (cond + ((car here) ; Opener. + (let ((data (smie-forward-sexp 'halfsexp)) + (tend (point))) + (unless (car data) + (funcall smie-backward-token-function) + (list (member (cons (nth 1 here) (nth 2 data)) + smie-closer-alist) + (point) tend)))) + (t ;Closer. + (let ((data (smie-backward-sexp 'halfsexp)) + (htok (nth 1 here))) + (if (car data) + (let* ((hprec (nth 2 (assoc htok smie-grammar))) + (ttok (nth 2 data)) + (tprec (nth 1 (assoc ttok smie-grammar)))) + (when (and (numberp hprec) ;Here is an inner. + (eq hprec tprec)) + (goto-char (nth 1 data)) + (let ((tbeg (point))) + (funcall smie-forward-token-function) + (list t tbeg (point))))) + (let ((tbeg (point))) + (funcall smie-forward-token-function) + (list (member (cons (nth 2 data) htok) + smie-closer-alist) + tbeg (point))))))))) + ;; Update the cache. + (setcdr smie--matching-block-data-cache + (list (nth 2 here) (nth 3 here) + (nth 1 there) (nth 2 there) + (not (nth 0 there))))))) + (scan-error nil)) + (goto-char (caar smie--matching-block-data-cache))) + (apply #'smie--matching-block-data orig args))) + ;;; The indentation engine. (defcustom smie-indent-basic 4 @@ -1043,6 +1135,10 @@ METHOD can be: - :list-intro, in which case ARG is a token and the function should return non-nil if TOKEN is followed by a list of expressions (not separated by any token) rather than an expression. +- :close-all, in which case ARG is a close-paren token at indentation and + the function should return non-nil if it should be aligned with the opener + of the last close-paren token on the same line, if there are multiple. + Otherwise, it will be aligned with its own opener. When ARG is a token, the function is called with point just before that token. A return value of nil always means to fallback on the default behavior, so the @@ -1067,12 +1163,13 @@ the beginning of a line." (save-excursion (<= (line-end-position) (progn - (when (zerop (length (funcall smie-forward-token-function))) - ;; Could be an open-paren. - (forward-char 1)) + (and (zerop (length (funcall smie-forward-token-function))) + (not (eobp)) + ;; Could be an open-paren. + (forward-char 1)) (skip-chars-forward " \t") (or (eolp) - (and (looking-at comment-start-skip) + (and ;; (looking-at comment-start-skip) ;(bug#16041). (forward-comment (point-max)))) (point)))))) @@ -1143,14 +1240,7 @@ Only meaningful when called from within `smie-rules-function'." (goto-char (cadr (smie-indent--parent))) (cons 'column (+ (or offset 0) - ;; Use smie-indent-virtual when indenting relative to an opener: - ;; this will also by default use current-column unless - ;; that opener is hanging, but will additionally consult - ;; rules-function, so it gives it a chance to tweak - ;; indentation (e.g. by forcing indentation relative to - ;; its own parent, as in fn a => fn b => fn c =>). - (if (or (listp (car smie--parent)) (smie-indent--hanging-p)) - (smie-indent-virtual) (current-column)))))) + (smie-indent-virtual))))) (defvar smie-rule-separator-outdent 2) @@ -1230,8 +1320,8 @@ Only meaningful when called from within `smie-rules-function'." (defun smie-indent--rule (method token ;; FIXME: Too many parameters. &optional after parent base-pos) - "Compute indentation column according to `indent-rule-functions'. -METHOD and TOKEN are passed to `indent-rule-functions'. + "Compute indentation column according to `smie-rules-function'. +METHOD and TOKEN are passed to `smie-rules-function'. AFTER is the position after TOKEN, if known. PARENT is the parent info returned by `smie-backward-sexp', if known. BASE-POS is the position relative to which offsets should be applied." @@ -1244,11 +1334,7 @@ BASE-POS is the position relative to which offsets should be applied." ;; - :after tok, where ;; ; after is set; parent=nil; base-pos=point; (save-excursion - (let ((offset - (let ((smie--parent parent) - (smie--token token) - (smie--after after)) - (funcall smie-rules-function method token)))) + (let ((offset (smie-indent--rule-1 method token after parent))) (cond ((not offset) nil) ((eq (car-safe offset) 'column) (cdr offset)) @@ -1269,6 +1355,12 @@ BASE-POS is the position relative to which offsets should be applied." (smie-indent-virtual) (current-column))))) (t (error "Unknown indentation offset %s" offset)))))) +(defun smie-indent--rule-1 (method token &optional after parent) + (let ((smie--parent parent) + (smie--token token) + (smie--after after)) + (funcall smie-rules-function method token))) + (defun smie-indent-forward-token () "Skip token forward and return it, along with its levels." (let ((tok (funcall smie-forward-token-function))) @@ -1276,8 +1368,13 @@ BASE-POS is the position relative to which offsets should be applied." ((< 0 (length tok)) (assoc tok smie-grammar)) ((looking-at "\\s(\\|\\s)\\(\\)") (forward-char 1) - (cons (buffer-substring (1- (point)) (point)) - (if (match-end 1) '(0 nil) '(nil 0))))))) + (cons (buffer-substring-no-properties (1- (point)) (point)) + (if (match-end 1) '(0 nil) '(nil 0)))) + ((looking-at "\\s\"\\|\\s|") + (forward-sexp 1) + nil) + ((eobp) nil) + (t (error "Bumped into unknown token"))))) (defun smie-indent-backward-token () "Skip token backward and return it, along with its levels." @@ -1288,8 +1385,13 @@ BASE-POS is the position relative to which offsets should be applied." ;; 4 == open paren syntax, 5 == close. ((memq (setq class (syntax-class (syntax-after (1- (point))))) '(4 5)) (forward-char -1) - (cons (buffer-substring (point) (1+ (point))) - (if (eq class 4) '(nil 0) '(0 nil))))))) + (cons (buffer-substring-no-properties (point) (1+ (point))) + (if (eq class 4) '(nil 0) '(0 nil)))) + ((memq class '(7 15)) + (backward-sexp 1) + nil) + ((bobp) nil) + (t (error "Bumped into unknown token"))))) (defun smie-indent-virtual () ;; We used to take an optional arg (with value :not-hanging) to specify that @@ -1327,8 +1429,13 @@ in order to figure out the indentation of some other (further down) point." (save-excursion ;; (forward-comment (point-max)) (when (looking-at "\\s)") - (while (not (zerop (skip-syntax-forward ")"))) - (skip-chars-forward " \t")) + (if (smie-indent--rule-1 :close-all + (buffer-substring-no-properties + (point) (1+ (point))) + (1+ (point))) + (while (not (zerop (skip-syntax-forward ")"))) + (skip-chars-forward " \t")) + (forward-char 1)) (condition-case nil (progn (backward-sexp 1) @@ -1350,8 +1457,11 @@ should not be computed on the basis of the following token." (if (and (< pos (line-beginning-position)) ;; Make sure `token' also *starts* on another line. (save-excursion - (smie-indent-backward-token) - (< pos (line-beginning-position)))) + (let ((endpos (point))) + (goto-char pos) + (forward-line 1) + (and (equal res (smie-indent-forward-token)) + (eq (point) endpos))))) nil (goto-char pos) res))))) @@ -1473,13 +1583,21 @@ should not be computed on the basis of the following token." (save-excursion (forward-comment (point-max)) (skip-chars-forward " \t\r\n") - ;; FIXME: We assume here that smie-indent-calculate will compute the - ;; indentation of the next token based on text before the comment, but - ;; this is not guaranteed, so maybe we should let - ;; smie-indent-calculate return some info about which buffer position - ;; was used as the "indentation base" and check that this base is - ;; before `pos'. - (smie-indent-calculate)))) + (unless + ;; Don't align with a closer, since the comment is "within" the + ;; closed element. Don't align with EOB either. + (save-excursion + (let ((next (funcall smie-forward-token-function))) + (or (if (zerop (length next)) + (or (eobp) (eq (car (syntax-after (point))) 5))) + (rassoc next smie-closer-alist)))) + ;; FIXME: We assume here that smie-indent-calculate will compute the + ;; indentation of the next token based on text before the comment, + ;; but this is not guaranteed, so maybe we should let + ;; smie-indent-calculate return some info about which buffer + ;; position was used as the "indentation base" and check that this + ;; base is before `pos'. + (smie-indent-calculate))))) (defun smie-indent-comment-continue () ;; indentation of comment-continue lines. @@ -1628,34 +1746,45 @@ to which that point should be aligned, if we were to reindent it.") (save-excursion (indent-line-to indent)) (indent-line-to indent))))) -(defun smie-auto-fill () +(defun smie-auto-fill (do-auto-fill) (let ((fc (current-fill-column))) - (while (and fc (> (current-column) fc)) - (cond - ((not (or (nth 8 (save-excursion - (syntax-ppss (line-beginning-position)))) - (nth 8 (syntax-ppss)))) - (save-excursion - (beginning-of-line) - (smie-indent-forward-token) - (let ((bsf (point)) - (gain 0) - curcol) - (while (<= (setq curcol (current-column)) fc) - ;; FIXME? `smie-indent-calculate' can (and often will) - ;; return a result that actually depends on the presence/absence - ;; of a newline, so the gain computed here may not be accurate, - ;; but in practice it seems to works well enough. - (let* ((newcol (smie-indent-calculate)) - (newgain (- curcol newcol))) - (when (> newgain gain) - (setq gain newgain) - (setq bsf (point)))) - (smie-indent-forward-token)) - (when (> gain 0) - (goto-char bsf) - (newline-and-indent))))) - (t (do-auto-fill)))))) + (when (and fc (> (current-column) fc)) + ;; The loop below presumes BOL is outside of strings or comments. Also, + ;; sometimes we prefer to fill the comment than the code around it. + (unless (or (nth 8 (save-excursion + (syntax-ppss (line-beginning-position)))) + (nth 4 (save-excursion + (move-to-column fc) + (syntax-ppss)))) + (while + (and (with-demoted-errors + (save-excursion + (let ((end (point)) + (bsf nil) ;Best-so-far. + (gain 0)) + (beginning-of-line) + (while (progn + (smie-indent-forward-token) + (and (<= (point) end) + (<= (current-column) fc))) + ;; FIXME? `smie-indent-calculate' can (and often + ;; does) return a result that actually depends on the + ;; presence/absence of a newline, so the gain computed + ;; here may not be accurate, but in practice it seems + ;; to work well enough. + (skip-chars-forward " \t") + (let* ((newcol (smie-indent-calculate)) + (newgain (- (current-column) newcol))) + (when (> newgain gain) + (setq gain newgain) + (setq bsf (point))))) + (when (> gain 0) + (goto-char bsf) + (newline-and-indent) + 'done)))) + (> (current-column) fc)))) + (when (> (current-column) fc) + (funcall do-auto-fill))))) (defun smie-setup (grammar rules-function &rest keywords) @@ -1665,12 +1794,11 @@ RULES-FUNCTION is a set of indentation rules for use on `smie-rules-function'. KEYWORDS are additional arguments, which can use the following keywords: - :forward-token FUN - :backward-token FUN" - (set (make-local-variable 'smie-rules-function) rules-function) - (set (make-local-variable 'smie-grammar) grammar) - (set (make-local-variable 'indent-line-function) 'smie-indent-line) - (set (make-local-variable 'normal-auto-fill-function) 'smie-auto-fill) - (set (make-local-variable 'forward-sexp-function) - 'smie-forward-sexp-command) + (setq-local smie-rules-function rules-function) + (setq-local smie-grammar grammar) + (setq-local indent-line-function #'smie-indent-line) + (add-function :around (local 'normal-auto-fill-function) #'smie-auto-fill) + (setq-local forward-sexp-function #'smie-forward-sexp-command) (while keywords (let ((k (pop keywords)) (v (pop keywords))) @@ -1682,30 +1810,388 @@ KEYWORDS are additional arguments, which can use the following keywords: (_ (message "smie-setup: ignoring unknown keyword %s" k))))) (let ((ca (cdr (assq :smie-closer-alist grammar)))) (when ca - (set (make-local-variable 'smie-closer-alist) ca) + (setq-local smie-closer-alist ca) ;; Only needed for interactive calls to blink-matching-open. - (set (make-local-variable 'blink-matching-check-function) - #'smie-blink-matching-check) + (setq-local blink-matching-check-function #'smie-blink-matching-check) (add-hook 'post-self-insert-hook #'smie-blink-matching-open 'append 'local) - (set (make-local-variable 'smie-blink-matching-triggers) - (append smie-blink-matching-triggers - ;; Rather than wait for SPC to blink, try to blink as - ;; soon as we type the last char of a block ender. - (let ((closers (sort (mapcar #'cdr smie-closer-alist) - #'string-lessp)) - (triggers ()) - closer) - (while (setq closer (pop closers)) - (unless (and closers - ;; FIXME: this eliminates prefixes of other - ;; closers, but we should probably - ;; eliminate prefixes of other keywords - ;; as well. - (string-prefix-p closer (car closers))) - (push (aref closer (1- (length closer))) triggers))) - (delete-dups triggers))))))) + (add-function :around (local 'show-paren-data-function) + #'smie--matching-block-data) + ;; Setup smie-blink-matching-triggers. Rather than wait for SPC to + ;; blink, try to blink as soon as we type the last char of a block ender. + (let ((closers (sort (mapcar #'cdr smie-closer-alist) #'string-lessp)) + (triggers ()) + closer) + (while (setq closer (pop closers)) + (unless + ;; FIXME: this eliminates prefixes of other closers, but we + ;; should probably eliminate prefixes of other keywords as well. + (and closers (string-prefix-p closer (car closers))) + (push (aref closer (1- (length closer))) triggers))) + (setq-local smie-blink-matching-triggers + (append smie-blink-matching-triggers + (delete-dups triggers))))))) + +(defun smie-edebug () + "Instrument the `smie-rules-function' for Edebug." + (interactive) + (require 'edebug) + (if (symbolp smie-rules-function) + (edebug-instrument-function smie-rules-function) + (error "Sorry, don't know how to instrument a lambda expression"))) +(defun smie--next-indent-change () + "Go to the next line that needs to be reindented (and reindent it)." + (interactive) + (while + (let ((tick (buffer-chars-modified-tick))) + (indent-according-to-mode) + (eq tick (buffer-chars-modified-tick))) + (forward-line 1))) + +;;; User configuration + +;; This is designed to be a completely independent "module", so we can play +;; with various kinds of smie-config modules without having to change the core. + +;; This smie-config module is fairly primitive and suffers from serious +;; restrictions: +;; - You can only change a returned offset, so you can't change the offset +;; passed to smie-rule-parent, nor can you change the object with which +;; to align (in general). +;; - The rewrite rule can only distinguish cases based on the kind+token arg +;; and smie-rules-function's return value, so you can't distinguish cases +;; where smie-rules-function returns the same value. +;; - Since config-rules depend on the return value of smie-rules-function, any +;; config change that modifies this return value (e.g. changing +;; foo-indent-basic) ends up invalidating config-rules. +;; This last one is a serious problem since it means that file-local +;; config-rules will only work if the user hasn't changed foo-indent-basic. +;; One possible way to change it is to modify smie-rules-functions so they can +;; return special symbols like +, ++, -, etc. Or make them use a new +;; smie-rule-basic function which can then be used to know when a returned +;; offset was computed based on foo-indent-basic. + +(defvar-local smie-config--mode-local nil + "Indentation config rules installed for this major mode. +Typically manipulated from the major-mode's hook.") +(defvar-local smie-config--buffer-local nil + "Indentation config rules installed for this very buffer. +E.g. provided via a file-local call to `smie-config-local'.") +(defvar smie-config--trace nil + "Variable used to trace calls to `smie-rules-function'.") + +(defun smie-config--advice (orig kind token) + (let* ((ret (funcall orig kind token)) + (sig (list kind token ret)) + (brule (rassoc sig smie-config--buffer-local)) + (mrule (rassoc sig smie-config--mode-local))) + (when smie-config--trace + (setq smie-config--trace (or brule mrule))) + (cond + (brule (car brule)) + (mrule (car mrule)) + (t ret)))) + +(defun smie-config--mode-hook (rules) + (setq smie-config--mode-local + (append rules smie-config--mode-local)) + (add-function :around (local 'smie-rules-function) #'smie-config--advice)) + +(defvar smie-config--modefuns nil) + +(defun smie-config--setter (var value) + (setq-default var value) + (let ((old-modefuns smie-config--modefuns)) + (setq smie-config--modefuns nil) + (pcase-dolist (`(,mode . ,rules) value) + (let ((modefunname (intern (format "smie-config--modefun-%s" mode)))) + (fset modefunname (lambda () (smie-config--mode-hook rules))) + (push modefunname smie-config--modefuns) + (add-hook (intern (format "%s-hook" mode)) modefunname))) + ;; Neuter any left-over previously installed hook. + (dolist (modefun old-modefuns) + (unless (memq modefun smie-config--modefuns) + (fset modefun #'ignore))))) + +(defcustom smie-config nil + ;; FIXME: there should be a file-local equivalent. + "User configuration of SMIE indentation. +This is a list of elements (MODE . RULES), where RULES is a list +of elements describing when and how to change the indentation rules. +Each RULE element should be of the form (NEW KIND TOKEN NORMAL), +where KIND and TOKEN are the elements passed to `smie-rules-function', +NORMAL is the value returned by `smie-rules-function' and NEW is the +value with which to replace it." + :version "24.4" + ;; FIXME improve value-type. + :type '(choice (const nil) + (alist :key-type symbol)) + :initialize 'custom-initialize-default + :set #'smie-config--setter) + +(defun smie-config-local (rules) + "Add RULES as local indentation rules to use in this buffer. +These replace any previous local rules, but supplement the rules +specified in `smie-config'." + (setq smie-config--buffer-local rules) + (add-function :around (local 'smie-rules-function) #'smie-config--advice)) + +;; Make it so we can set those in the file-local block. +;; FIXME: Better would be to be able to write "smie-config-local: (...)" rather +;; than "eval: (smie-config-local '(...))". +(put 'smie-config-local 'safe-local-eval-function t) + +(defun smie-config--get-trace () + (save-excursion + (forward-line 0) + (skip-chars-forward " \t") + (let* ((trace ()) + (srf-fun (lambda (orig kind token) + (let* ((pos (point)) + (smie-config--trace t) + (res (funcall orig kind token))) + (push (if (consp smie-config--trace) + (list pos kind token res smie-config--trace) + (list pos kind token res)) + trace) + res)))) + (unwind-protect + (progn + (add-function :around (local 'smie-rules-function) srf-fun) + (cons (smie-indent-calculate) + trace)) + (remove-function (local 'smie-rules-function) srf-fun))))) + +(defun smie-config-show-indent (&optional arg) + "Display the SMIE rules that are used to indent the current line. +If prefix ARG is given, then move briefly point to the buffer +position corresponding to each rule." + (interactive "P") + (let ((trace (cdr (smie-config--get-trace)))) + (cond + ((null trace) (message "No SMIE rules involved")) + ((not arg) + (message "Rules used: %s" + (mapconcat (lambda (elem) + (pcase-let ((`(,_pos ,kind ,token ,res ,rewrite) + elem)) + (format "%S %S -> %S%s" kind token res + (if (null rewrite) "" + (format "(via %S)" (nth 3 rewrite)))))) + trace + ", "))) + (t + (save-excursion + (pcase-dolist (`(,pos ,kind ,token ,res ,rewrite) trace) + (message "%S %S -> %S%s" kind token res + (if (null rewrite) "" + (format "(via %S)" (nth 3 rewrite)))) + (goto-char pos) + (sit-for blink-matching-delay))))))) + +(defun smie-config--guess-value (sig) + (add-function :around (local 'smie-rules-function) #'smie-config--advice) + (let* ((rule (cons 0 sig)) + (smie-config--buffer-local (cons rule smie-config--buffer-local)) + (goal (current-indentation)) + (cur (smie-indent-calculate))) + (cond + ((and (eq goal + (progn (setf (car rule) (- goal cur)) + (smie-indent-calculate)))) + (- goal cur))))) + +(defun smie-config-set-indent () + "Add a rule to adjust the indentation of current line." + (interactive) + (let* ((trace (cdr (smie-config--get-trace))) + (_ (unless trace (error "No SMIE rules involved"))) + (sig (if (null (cdr trace)) + (pcase-let* ((elem (car trace)) + (`(,_pos ,kind ,token ,res ,rewrite) elem)) + (list kind token (or (nth 3 rewrite) res))) + (let* ((choicestr + (completing-read + "Adjust rule: " + (mapcar (lambda (elem) + (format "%s %S" + (substring (symbol-name (cadr elem)) + 1) + (nth 2 elem))) + trace) + nil t nil nil + nil)) ;FIXME: Provide good default! + (choicelst (car (read-from-string + (concat "(:" choicestr ")"))))) + (catch 'found + (pcase-dolist (`(,_pos ,kind ,token ,res ,rewrite) trace) + (when (and (eq kind (car choicelst)) + (equal token (nth 1 choicelst))) + (throw 'found (list kind token + (or (nth 3 rewrite) res))))))))) + (default-new (smie-config--guess-value sig)) + (newstr (read-string (format "Adjust rule (%S %S -> %S) to%s: " + (nth 0 sig) (nth 1 sig) (nth 2 sig) + (if (not default-new) "" + (format " (default %S)" default-new))) + nil nil (format "%S" default-new))) + (new (car (read-from-string newstr)))) + (let ((old (rassoc sig smie-config--buffer-local))) + (when old + (setq smie-config--buffer-local + (remove old smie-config--buffer-local)))) + (push (cons new sig) smie-config--buffer-local) + (message "Added rule %S %S -> %S (via %S)" + (nth 0 sig) (nth 1 sig) new (nth 2 sig)) + (add-function :around (local 'smie-rules-function) #'smie-config--advice))) + +(defun smie-config--guess (beg end) + (let ((otraces (make-hash-table :test #'equal)) + (smie-config--buffer-local nil) + (smie-config--mode-local nil) + (pr (make-progress-reporter "Analyzing the buffer" beg end))) + + ;; First, lets get the indentation traces and offsets for the region. + (save-excursion + (goto-char beg) + (forward-line 0) + (while (< (point) end) + (skip-chars-forward " \t") + (unless (eolp) ;Skip empty lines. + (progress-reporter-update pr (point)) + (let* ((itrace (smie-config--get-trace)) + (nindent (car itrace)) + (trace (mapcar #'cdr (cdr itrace))) + (cur (current-indentation))) + (when (numberp nindent) ;Skip `noindent' and friends. + (cl-incf (gethash (cons (- cur nindent) trace) otraces 0))))) + (forward-line 1))) + (progress-reporter-done pr) + + ;; Second, compile the data. Our algorithm only knows how to adjust rules + ;; where the smie-rules-function returns an integer. We call those + ;; "adjustable sigs". We build a table mapping each adjustable sig + ;; to its data, describing the total number of times we encountered it, + ;; the offsets found, and the traces in which it was found. + (message "Guessing...") + (let ((sigs (make-hash-table :test #'equal))) + (maphash (lambda (otrace count) + (let ((offset (car otrace)) + (trace (cdr otrace)) + (double nil)) + (let ((sigs trace)) + (while sigs + (let ((sig (pop sigs))) + (if (and (integerp (nth 2 sig)) (member sig sigs)) + (setq double t))))) + (if double + ;; Disregard those traces where an adjustable sig + ;; appears twice, because the rest of the code assumes + ;; that adding a rule to add an offset N will change the + ;; end result by N rather than 2*N or more. + nil + (dolist (sig trace) + (if (not (integerp (nth 2 sig))) + ;; Disregard those sigs that return nil or a column, + ;; because our algorithm doesn't know how to adjust + ;; them anyway. + nil + (let ((sig-data (or (gethash sig sigs) + (let ((data (list 0 nil nil))) + (puthash sig data sigs) + data)))) + (cl-incf (nth 0 sig-data) count) + (push (cons count otrace) (nth 2 sig-data)) + (let ((sig-off-data + (or (assq offset (nth 1 sig-data)) + (let ((off-data (cons offset 0))) + (push off-data (nth 1 sig-data)) + off-data)))) + (cl-incf (cdr sig-off-data) count)))))))) + otraces) + + ;; Finally, guess the indentation rules. + (let ((ssigs nil) + (rules nil)) + ;; Sort the sigs by frequency of occurrence. + (maphash (lambda (sig sig-data) (push (cons sig sig-data) ssigs)) sigs) + (setq ssigs (sort ssigs (lambda (sd1 sd2) (> (cadr sd1) (cadr sd2))))) + (while ssigs + (pcase-let ((`(,sig ,total ,off-alist ,cotraces) (pop ssigs))) + (cl-assert (= total (apply #'+ (mapcar #'cdr off-alist)))) + (let* ((sorted-off-alist + (sort off-alist (lambda (x y) (> (cdr x) (cdr y))))) + (offset (caar sorted-off-alist))) + (if (zerop offset) + ;; Nothing to do with this sig; indentation is + ;; correct already. + nil + (push (cons (+ offset (nth 2 sig)) sig) rules) + ;; Adjust the rest of the data. + (pcase-dolist ((and cotrace `(,count ,toffset ,trace)) + cotraces) + (setf (nth 1 cotrace) (- toffset offset)) + (dolist (sig trace) + (let ((sig-data (cdr (assq sig ssigs)))) + (when sig-data + (let* ((ooff-data (assq toffset (nth 1 sig-data))) + (noffset (- toffset offset)) + (noff-data + (or (assq noffset (nth 1 sig-data)) + (let ((off-data (cons noffset 0))) + (push off-data (nth 1 sig-data)) + off-data)))) + (cl-assert (>= (cdr ooff-data) count)) + (cl-decf (cdr ooff-data) count) + (cl-incf (cdr noff-data) count)))))))))) + (message "Guessing...done") + rules)))) + +(defun smie-config-guess () + "Try and figure out this buffer's indentation settings." + (interactive) + (let ((config (smie-config--guess (point-min) (point-max)))) + (cond + ((null config) (message "Nothing to change")) + ((null smie-config--buffer-local) + (message "Local rules set") + (setq smie-config--buffer-local config)) + ((y-or-n-p "Replace existing local config? ") + (message "Local rules replaced") + (setq smie-config--buffer-local config)) + ((y-or-n-p "Merge with existing local config? ") + (message "Local rules adjusted") + (setq smie-config--buffer-local + (append config smie-config--buffer-local))) + (t + (message "Rules guessed: %S" config))))) + +(defun smie-config-save () + "Save local rules for use with this major mode." + (interactive) + (cond + ((null smie-config--buffer-local) + (message "No local rules to save")) + (t + (let* ((existing (assq major-mode smie-config)) + (config + (cond ((null existing) + (message "Local rules saved in `smie-config'") + smie-config--buffer-local) + ((y-or-n-p "Replace the existing mode's config? ") + (message "Mode rules replaced in `smie-config'") + smie-config--buffer-local) + ((y-or-n-p "Merge with existing mode's config? ") + (message "Mode rules adjusted in `smie-config'") + (append smie-config--buffer-local (cdr existing))) + (t (error "Abort"))))) + (if existing + (setcdr existing config) + (push (cons major-mode config) smie-config)) + (setq smie-config--mode-local config) + (kill-local-variable smie-config--buffer-local) + (customize-mark-as-set 'smie-config))))) (provide 'smie) ;;; smie.el ends here diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el new file mode 100644 index 00000000000..505a556b65f --- /dev/null +++ b/lisp/emacs-lisp/subr-x.el @@ -0,0 +1,93 @@ +;;; subr-x.el --- extra Lisp functions -*- lexical-binding:t -*- + +;; Copyright (C) 2013-2014 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org +;; Keywords: convenience +;; 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: + +;; Less commonly used functions that complement basic APIs, often implemented in +;; C code (like hash-tables and strings), and are not eligible for inclusion +;; in subr.el. + +;; Do not document these functions in the lispref. +;; http://lists.gnu.org/archive/html/emacs-devel/2014-01/msg01006.html + +;;; Code: + +(defsubst hash-table-keys (hash-table) + "Return a list of keys in HASH-TABLE." + (let ((keys '())) + (maphash (lambda (k _v) (push k keys)) hash-table) + keys)) + +(defsubst hash-table-values (hash-table) + "Return a list of values in HASH-TABLE." + (let ((values '())) + (maphash (lambda (_k v) (push v values)) hash-table) + values)) + +(defsubst string-empty-p (string) + "Check whether STRING is empty." + (string= string "")) + +(defsubst string-join (strings &optional separator) + "Join all STRINGS using SEPARATOR." + (mapconcat 'identity strings separator)) + +(defsubst string-reverse (str) + "Reverse the string STR." + (apply 'string (nreverse (string-to-list str)))) + +(defsubst string-trim-left (string) + "Remove leading whitespace from STRING." + (if (string-match "\\`[ \t\n\r]+" string) + (replace-match "" t t string) + string)) + +(defsubst string-trim-right (string) + "Remove trailing whitespace from STRING." + (if (string-match "[ \t\n\r]+\\'" string) + (replace-match "" t t string) + string)) + +(defsubst string-trim (string) + "Remove leading and trailing whitespace from STRING." + (string-trim-left (string-trim-right string))) + +(defsubst string-blank-p (string) + "Check whether STRING is either empty or only whitespace." + (string-match-p "\\`[ \t\n\r]*\\'" string)) + +(defsubst string-remove-prefix (prefix string) + "Remove PREFIX from STRING if present." + (if (string-prefix-p prefix string) + (substring string (length prefix)) + string)) + +(defsubst string-remove-suffix (suffix string) + "Remove SUFFIX from STRING if present." + (if (string-suffix-p suffix string) + (substring string 0 (- (length string) (length suffix))) + string)) + +(provide 'subr-x) + +;;; subr-x.el ends here diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index bf2c8308bb5..db68148ea5d 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -1,8 +1,8 @@ ;;; syntax.el --- helper functions to find syntactic context -*- lexical-binding: t -*- -;; Copyright (C) 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 2000-2014 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal ;; This file is part of GNU Emacs. @@ -56,12 +56,13 @@ ;; 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. +It is the work horse of `syntax-propertize', which is called by things like +Font-Lock and indentation. + +It is given two arguments, START and END: the start and end of the text to +which `syntax-table' might need to be applied. Major modes can use this to +override the buffer's syntax table for special syntactic constructs that +cannot be handled just by the buffer's syntax-table. The specified function may call `syntax-ppss' on any position before END, but it should not call `syntax-ppss-flush-cache', @@ -99,7 +100,7 @@ Put first the functions more likely to cause a change and cheaper to compute.") (setq beg (or (previous-single-property-change beg 'syntax-multiline) (point-min)))) ;; - (when (get-text-property end 'font-lock-multiline) + (when (get-text-property end 'syntax-multiline) (setq end (or (text-property-any end (point-max) 'syntax-multiline nil) (point-max)))) @@ -404,9 +405,14 @@ 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 that of `parse-partial-sexp' -run from point-min to POS except that values at positions 2 and 6 +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." +Point is at POS when this function returns. + +It is necessary to call `syntax-ppss-flush-cache' explicitly if +this function is called while `before-change-functions' is +temporarily let-bound, or if the buffer is modified without +running the hook." ;; Default values. (unless pos (setq pos (point))) (syntax-propertize pos) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index da487e463e2..d0d71ddb935 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -1,9 +1,10 @@ ;;; tabulated-list.el --- generic major mode for tabulated lists -*- lexical-binding: t -*- -;; Copyright (C) 2011-2013 Free Software Foundation, Inc. +;; Copyright (C) 2011-2014 Free Software Foundation, Inc. ;; Author: Chong Yidong <cyd@stupidchicken.com> ;; Keywords: extensions, lisp +;; Version: 1.0 ;; This file is part of GNU Emacs. @@ -40,7 +41,7 @@ ;; major mode, switch back, and have the original Tabulated List data ;; still valid. See, for example, ebuff-menu.el. -(defvar tabulated-list-format nil +(defvar-local 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: @@ -57,17 +58,15 @@ where: 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. + - `: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 +(defvar-local 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 +(defvar-local 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]), @@ -85,28 +84,25 @@ where: 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 +(defvar-local 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 +(defvar-local 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 +(defvar-local 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). @@ -114,7 +110,6 @@ 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) @@ -235,7 +230,7 @@ If ADVANCE is non-nil, move forward by one line afterwards." `(space :align-to ,(+ x shift))) (cdr cols)))) (setq x (+ x shift))))) - (if (> pad-right 0) + (if (>= pad-right 0) (push (propertize " " 'display `(space :align-to ,next-x) 'face 'fixed-pitch) @@ -245,7 +240,7 @@ If ADVANCE is non-nil, move forward by one line afterwards." (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)))) + (setq-local tabulated-list--header-string cols)))) (defun tabulated-list-print-fake-header () "Insert a fake Tabulated List \"header line\" at the start of the buffer." @@ -254,8 +249,8 @@ If ADVANCE is non-nil, move forward by one line afterwards." (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)))) + (setq-local tabulated-list--header-overlay + (make-overlay (point-min) (point)))) (overlay-put tabulated-list--header-overlay 'face 'underline))) (defun tabulated-list-revert (&rest ignored) @@ -350,7 +345,7 @@ of column descriptors." (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 +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 @@ -519,12 +514,11 @@ printer is `tabulated-list-print-entry', but a mode that keeps data in an ewoc may instead specify a printer function (e.g., one that calls `ewoc-enter-last'), with `tabulated-list-print-entry' as the ewoc pretty-printer." - (setq truncate-lines t) - (setq buffer-read-only t) - (set (make-local-variable 'revert-buffer-function) - 'tabulated-list-revert) - (set (make-local-variable 'glyphless-char-display) - tabulated-list-glyphless-char-display)) + (setq-local truncate-lines t) + (setq-local buffer-read-only t) + (setq-local buffer-undo-list t) + (setq-local revert-buffer-function #'tabulated-list-revert) + (setq-local glyphless-char-display tabulated-list-glyphless-char-display)) (put 'tabulated-list-mode 'mode-class 'special) diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index 02023b957a5..02f8dc6e559 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -1,6 +1,6 @@ ;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -;; Copyright (C) 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2014 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el index e557e1c30c1..2bc40d14226 100644 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -1,6 +1,6 @@ ;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage -;; Copyright (C) 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2014 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index f6bd26e9f34..7ab211360a8 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-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2014 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> @@ -100,14 +100,14 @@ current global map. The macro `lambda' is self-evaluating, hence always returns the same value (the function it defines may return varying values when called)." :group 'testcover - :type 'hook) + :type '(repeat symbol)) (defcustom testcover-noreturn-functions '(error noreturn throw signal) "Subset of `testcover-1value-functions' -- these never return. We mark them as having returned nil just before calling them." :group 'testcover - :type 'hook) + :type '(repeat symbol)) (defcustom testcover-compose-functions '(+ - * / = append length list make-keymap make-sparse-keymap @@ -118,7 +118,7 @@ calls to one of the `testcover-1value-functions', so if that's true then no brown splotch is shown for these. This list is quite incomplete! Most side-effect-free functions should be here." :group 'testcover - :type 'hook) + :type '(repeat symbol)) (defcustom testcover-progn-functions '(define-key fset function goto-char mapc overlay-put progn @@ -132,7 +132,7 @@ brown splotch is shown for these if the last argument is a constant or a call to one of the `testcover-1value-functions'. This list is probably incomplete!" :group 'testcover - :type 'hook) + :type '(repeat symbol)) (defcustom testcover-prog1-functions '(prog1 unwind-protect) @@ -140,13 +140,14 @@ incomplete!" brown splotch is shown for these if the first argument is a constant or a call to one of the `testcover-1value-functions'." :group 'testcover - :type 'hook) + :type '(repeat symbol)) (defcustom testcover-potentially-1value-functions '(add-hook and beep or remove-hook unless when) "Functions that are potentially 1-valued. No brown splotch if actually 1-valued, no error if actually multi-valued." - :group 'testcover) + :group 'testcover + :type '(repeat symbol)) (defface testcover-nohits '((t (:background "DeepPink2"))) diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 8b019d0a785..515bbc36a06 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -1,8 +1,8 @@ ;;; timer.el --- run a function with args at some time in future -;; Copyright (C) 1996, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1996, 2001-2014 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Package: emacs ;; This file is part of GNU Emacs. @@ -27,52 +27,57 @@ ;;; Code: -;; Layout of a timer vector: -;; [triggered-p high-seconds low-seconds usecs repeat-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-lib)) (cl-defstruct (timer - (:constructor nil) - (:copier nil) - (:constructor timer-create ()) - (:type vector) - (:conc-name timer--)) + (:constructor nil) + (:copier nil) + (:constructor timer-create ()) + (:type vector) + (:conc-name timer--)) + ;; nil if the timer is active (waiting to be triggered), + ;; non-nil if it is inactive ("already triggered", in theory). (triggered t) - high-seconds low-seconds usecs repeat-delay function args idle-delay psecs) + ;; Time of next trigger: for normal timers, absolute time, for idle timers, + ;; time relative to idle-start. + high-seconds low-seconds usecs + ;; For normal timers, time between repetitions, or nil. For idle timers, + ;; non-nil iff repeated. + repeat-delay + function args ;What to do when triggered. + idle-delay ;If non-nil, this is an idle-timer. + psecs) (defun timerp (object) "Return t if OBJECT is a timer." (and (vectorp object) (= (length object) 9))) +(defsubst timer--check (timer) + (or (timerp timer) (signal 'wrong-type-argument (list #'timerp timer)))) + +(defun timer--time-setter (timer time) + (timer--check timer) + (setf (timer--high-seconds timer) (pop time)) + (let ((low time) (usecs 0) (psecs 0)) + (when (consp time) + (setq low (pop time)) + (when time + (setq usecs (pop time)) + (when time + (setq psecs (car time))))) + (setf (timer--low-seconds timer) low) + (setf (timer--usecs timer) usecs) + (setf (timer--psecs timer) psecs) + time)) + ;; Pseudo field `time'. (defun timer--time (timer) + (declare (gv-setter timer--time-setter)) (list (timer--high-seconds timer) (timer--low-seconds timer) (timer--usecs timer) (timer--psecs timer))) -(gv-define-simple-setter timer--time - (lambda (timer time) - (or (timerp timer) (error "Invalid timer")) - (setf (timer--high-seconds timer) (pop time)) - (let ((low time) (usecs 0) (psecs 0)) - (if (consp time) - (progn - (setq low (pop time)) - (if time - (progn - (setq usecs (pop time)) - (if time - (setq psecs (car time))))))) - (setf (timer--low-seconds timer) low) - (setf (timer--usecs timer) usecs) - (setf (timer--psecs timer) psecs)))) - - (defun timer-set-time (timer time &optional delta) "Set the trigger time of TIMER to TIME. TIME must be in the internal format returned by, e.g., `current-time'. @@ -83,15 +88,13 @@ fire repeatedly that many seconds apart." timer) (defun timer-set-idle-time (timer secs &optional repeat) + ;; FIXME: Merge with timer-set-time. "Set the trigger idle time of TIMER to SECS. SECS may be an integer, floating point number, or the internal time format returned by, e.g., `current-idle-time'. If optional third argument REPEAT is non-nil, make the timer fire each time Emacs is idle for that many seconds." - (if (consp secs) - (setf (timer--time timer) secs) - (setf (timer--time timer) '(0 0 0)) - (timer-inc-time timer secs)) + (setf (timer--time timer) (if (consp secs) secs (seconds-to-time secs))) (setf (timer--repeat-delay timer) repeat) timer) @@ -119,7 +122,7 @@ of SECS seconds since the epoch. SECS may be a fraction." (floor (mod next-sec-psec 1000000))))) (defun timer-relative-time (time secs &optional usecs psecs) - "Advance TIME by SECS seconds and optionally USECS nanoseconds + "Advance TIME by SECS seconds and optionally USECS microseconds and PSECS picoseconds. SECS may be either an integer or a floating point number." (let ((delta (if (floatp secs) @@ -134,7 +137,7 @@ floating point number." (time-less-p (timer--time t1) (timer--time t2))) (defun timer-inc-time (timer secs &optional usecs psecs) - "Increment the time set in TIMER by SECS seconds, USECS nanoseconds, + "Increment the time set in TIMER by SECS seconds, USECS microseconds, and PSECS picoseconds. SECS may be a fraction. If USECS or PSECS are omitted, they are treated as zero." (setf (timer--time timer) @@ -156,8 +159,7 @@ fire repeatedly that many seconds apart." (defun timer-set-function (timer function &optional args) "Make TIMER call FUNCTION with optional ARGS when triggering." - (or (timerp timer) - (error "Invalid timer")) + (timer--check timer) (setf (timer--function timer) function) (setf (timer--args timer) args) timer) @@ -181,9 +183,10 @@ fire repeatedly that many seconds apart." (setcdr reuse-cell timers)) (setq reuse-cell (cons timer timers))) ;; Insert new timer after last which possibly means in front of queue. - (cond (last (setcdr last reuse-cell)) - (idle (setq timer-idle-list reuse-cell)) - (t (setq timer-list reuse-cell))) + (setf (cond (last (cdr last)) + (idle timer-idle-list) + (t timer-list)) + reuse-cell) (setf (timer--triggered timer) triggered-p) (setf (timer--idle-delay timer) idle) nil) @@ -223,8 +226,7 @@ timer will fire right away." (defun cancel-timer (timer) "Remove TIMER from the list of active timers." - (or (timerp timer) - (error "Invalid timer")) + (timer--check timer) (setq timer-list (delq timer timer-list)) (setq timer-idle-list (delq timer timer-idle-list)) nil) @@ -283,40 +285,47 @@ This function is called, by name, directly by the C code." (setq timer-event-last-1 timer-event-last) (setq timer-event-last timer) (let ((inhibit-quit t)) - (if (timerp timer) - (let (retrigger cell) - ;; Delete from queue. Record the cons cell that was used. - (setq cell (cancel-timer-internal timer)) - ;; Re-schedule if requested. - (if (timer--repeat-delay timer) - (if (timer--idle-delay timer) - (timer-activate-when-idle timer nil cell) - (timer-inc-time timer (timer--repeat-delay timer) 0) - ;; If real time has jumped forward, - ;; perhaps because Emacs was suspended for a long time, - ;; limit how many times things get repeated. - (if (and (numberp timer-max-repeats) - (< 0 (timer-until timer (current-time)))) - (let ((repeats (/ (timer-until timer (current-time)) - (timer--repeat-delay timer)))) - (if (> repeats timer-max-repeats) - (timer-inc-time timer (* (timer--repeat-delay timer) - repeats))))) - (timer-activate timer t cell) - (setq retrigger t))) - ;; Run handler. - ;; We do this after rescheduling so that the handler function - ;; can cancel its own timer successfully with cancel-timer. - (condition-case-unless-debug err - ;; Timer functions should not change the current buffer. - ;; If they do, all kinds of nasty surprises can happen, - ;; and it can be hellish to track down their source. - (save-current-buffer - (apply (timer--function timer) (timer--args timer))) - (error (message "Error in timer: %S" err))) - (if retrigger - (setf (timer--triggered timer) nil))) - (error "Bogus timer event")))) + (timer--check timer) + (let ((retrigger nil) + (cell + ;; Delete from queue. Record the cons cell that was used. + (cancel-timer-internal timer))) + ;; Re-schedule if requested. + (if (timer--repeat-delay timer) + (if (timer--idle-delay timer) + (timer-activate-when-idle timer nil cell) + (timer-inc-time timer (timer--repeat-delay timer) 0) + ;; If real time has jumped forward, + ;; perhaps because Emacs was suspended for a long time, + ;; limit how many times things get repeated. + (if (and (numberp timer-max-repeats) + (< 0 (timer-until timer (current-time)))) + (let ((repeats (/ (timer-until timer (current-time)) + (timer--repeat-delay timer)))) + (if (> repeats timer-max-repeats) + (timer-inc-time timer (* (timer--repeat-delay timer) + repeats))))) + ;; Place it back on the timer-list before running + ;; timer--function, so it can cancel-timer itself. + (timer-activate timer t cell) + (setq retrigger t))) + ;; Run handler. + (condition-case-unless-debug err + ;; Timer functions should not change the current buffer. + ;; If they do, all kinds of nasty surprises can happen, + ;; and it can be hellish to track down their source. + (save-current-buffer + (apply (timer--function timer) (timer--args timer))) + (error (message "Error running timer%s: %S" + (if (symbolp (timer--function timer)) + (format " `%s'" (timer--function timer)) "") + err))) + (when (and retrigger + ;; If the timer's been canceled, don't "retrigger" it + ;; since it might still be in the copy of timer-list kept + ;; by keyboard.c:timer_check (bug#14156). + (memq timer timer-list)) + (setf (timer--triggered timer) nil))))) ;; This function is incompatible with the one in levents.el. (defun timeout-event-p (event) @@ -527,6 +536,12 @@ If the user does not answer after SECONDS seconds, return DEFAULT-VALUE." secs (if (string-match-p "\\`[0-9.]+\\'" string) (string-to-number string))))) + +(defun internal-timer-start-idle () + "Mark all idle-time timers as once again candidates for running." + (dolist (timer timer-idle-list) + (if (timerp timer) ;; FIXME: Why test? + (setf (timer--triggered timer) nil)))) (provide 'timer) diff --git a/lisp/emacs-lisp/tq.el b/lisp/emacs-lisp/tq.el index d308ce694d2..09ed23630da 100644 --- a/lisp/emacs-lisp/tq.el +++ b/lisp/emacs-lisp/tq.el @@ -1,10 +1,10 @@ -;;; tq.el --- utility to maintain a transaction queue +;;; tq.el --- utility to maintain a transaction queue -*- lexical-binding:t -*- -;; Copyright (C) 1985-1987, 1992, 2001-2013 Free Software Foundation, +;; Copyright (C) 1985-1987, 1992, 2001-2014 Free Software Foundation, ;; Inc. ;; Author: Scott Draves <spot@cs.cmu.edu> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Adapted-By: ESR ;; Keywords: extensions @@ -87,8 +87,7 @@ to a tcp server on another machine." (process-name process))))))) (buffer-disable-undo (tq-buffer tq)) (set-process-filter process - `(lambda (proc string) - (tq-filter ',tq string))) + (lambda (_proc string) (tq-filter tq string))) tq)) (defun tq-queue-add (tq question re closure fn) diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 09c4969cf18..872bf86e545 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -1,9 +1,9 @@ ;;; trace.el --- tracing facility for Emacs Lisp functions -*- lexical-binding: t -*- -;; Copyright (C) 1993, 1998, 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1998, 2000-2014 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Created: 15 Dec 1992 ;; Keywords: tools, lisp @@ -32,9 +32,9 @@ ;; Introduction: ;; ============= -;; A simple trace package that utilizes advice.el. It generates trace +;; A simple trace package that utilizes nadvice.el. It generates trace ;; information in a Lisp-style fashion and inserts it into a trace output -;; buffer. Tracing can be done in the background (or silently) so that +;; buffer. Tracing can be done in the background (or silently) so that ;; generation of trace output won't interfere with what you are currently ;; doing. @@ -48,15 +48,14 @@ ;; + Compiled calls to subrs that have special byte-codes associated ;; with them (e.g., car, cdr, ...) ;; + Macros that were expanded during compilation -;; - All the restrictions that apply to advice.el +;; - All the restrictions that apply to nadvice.el ;; Usage: ;; ====== -;; - To trace a function say `M-x trace-function' which will ask you for the -;; name of the function/subr/macro to trace, as well as for the buffer -;; into which trace output should go. +;; - To trace a function say `M-x trace-function', which will ask you for the +;; name of the function/subr/macro to trace. ;; - If you want to trace a function that switches buffers or does other -;; display oriented stuff use `M-x trace-function-background' which will +;; display oriented stuff use `M-x trace-function-background', which will ;; generate the trace output silently in the background without popping ;; up windows and doing other irritating stuff. ;; - To untrace a function say `M-x untrace-function'. @@ -157,6 +156,17 @@ (defvar inhibit-trace nil "If non-nil, all tracing is temporarily inhibited.") +;;;###autoload +(defun trace-values (&rest values) + "Helper function to get internal values. +You can call this function to add internal values in the trace buffer." + (unless inhibit-trace + (with-current-buffer trace-buffer + (goto-char (point-max)) + (insert + (trace-entry-message + 'trace-values trace-level values ""))))) + (defun trace-entry-message (function level args context) "Generate a string that describes that FUNCTION has been entered. LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION, @@ -189,6 +199,18 @@ some global variables)." (defvar trace--timer nil) +(defun trace--display-buffer (buf) + (unless (or trace--timer + (get-buffer-window buf 'visible)) + (setq trace--timer + ;; Postpone the display to some later time, in case we + ;; can't actually do it now. + (run-with-timer 0 nil + (lambda () + (setq trace--timer nil) + (display-buffer buf nil 0)))))) + + (defun trace-make-advice (function buffer background context) "Build the piece of advice to be added to trace FUNCTION. FUNCTION is the name of the traced function. @@ -199,19 +221,12 @@ be printed along with the arguments in the trace." (lambda (body &rest args) (let ((trace-level (1+ trace-level)) (trace-buffer (get-buffer-create buffer)) + (deactivate-mark nil) ;Protect deactivate-mark. (ctx (funcall context))) (unless inhibit-trace (with-current-buffer trace-buffer (set (make-local-variable 'window-point-insertion-type) t) - (unless (or background trace--timer - (get-buffer-window trace-buffer 'visible)) - (setq trace--timer - ;; Postpone the display to some later time, in case we - ;; can't actually do it now. - (run-with-timer 0 nil - (lambda () - (setq trace--timer nil) - (display-buffer trace-buffer))))) + (unless background (trace--display-buffer trace-buffer)) (goto-char (point-max)) ;; Insert a separator from previous trace output: (if (= trace-level 1) (insert trace-separator)) @@ -224,7 +239,7 @@ be printed along with the arguments in the trace." (unless inhibit-trace (let ((ctx (funcall context))) (with-current-buffer trace-buffer - (unless background (display-buffer trace-buffer)) + (unless background (trace--display-buffer trace-buffer)) (goto-char (point-max)) (insert (trace-exit-message @@ -240,14 +255,27 @@ be printed along with the arguments in the trace." function :around (trace-make-advice function (or buffer trace-buffer) background (or context (lambda () ""))) - `((name . ,trace-advice-name)))) + `((name . ,trace-advice-name) (depth . -100)))) (defun trace-is-traced (function) (advice-member-p trace-advice-name function)) (defun trace--read-args (prompt) + "Read a function name, prompting with string PROMPT. +If `current-prefix-arg' is non-nil, also read a buffer and a \"context\" +\(Lisp expression). Return (FUNCTION BUFFER FUNCTION-CONTEXT)." (cons - (intern (completing-read prompt obarray 'fboundp t)) + (let ((default (function-called-at-point)) + (beg (string-match ":[ \t]*\\'" prompt))) + (intern (completing-read (if default + (format + "%s (default %s)%s" + (substring prompt 0 beg) + default + (if beg (substring prompt beg) ": ")) + prompt) + obarray 'fboundp t nil nil + (if default (symbol-name default))))) (when current-prefix-arg (list (read-buffer "Output to buffer: " trace-buffer) @@ -262,23 +290,30 @@ be printed along with the arguments in the trace." ;;;###autoload (defun trace-function-foreground (function &optional buffer context) - "Traces FUNCTION with trace output going to BUFFER. -For every call of FUNCTION Lisp-style trace messages that display argument -and return values will be inserted into BUFFER. This function generates the -trace advice for FUNCTION and activates it together with any other advice -there might be!! The trace BUFFER will popup whenever FUNCTION is called. -Do not use this to trace functions that switch buffers or do any other -display oriented stuff, use `trace-function-background' instead. - -To untrace a function, use `untrace-function' or `untrace-all'." + "Trace calls to function FUNCTION. +With a prefix argument, also prompt for the trace buffer (default +`trace-buffer'), and a Lisp expression CONTEXT. + +Tracing a function causes every call to that function to insert +into BUFFER Lisp-style trace messages that display the function's +arguments and return values. It also evaluates CONTEXT, if that is +non-nil, and inserts its value too. For example, you can use this +to track the current buffer, or position of point. + +This function creates BUFFER if it does not exist. This buffer will +popup whenever FUNCTION is called. Do not use this function to trace +functions that switch buffers, or do any other display-oriented +stuff - use `trace-function-background' instead. + +To stop tracing a function, use `untrace-function' or `untrace-all'." (interactive (trace--read-args "Trace function: ")) (trace-function-internal function buffer nil context)) ;;;###autoload (defun trace-function-background (function &optional buffer context) - "Traces FUNCTION with trace output going quietly to BUFFER. -Like `trace-function-foreground' but without popping up the trace BUFFER or -changing the window configuration." + "Trace calls to function FUNCTION, quietly. +This is like `trace-function-foreground', but without popping up +the output buffer or changing the window configuration." (interactive (trace--read-args "Trace function in background: ")) (trace-function-internal function buffer t context)) diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 699392fb349..b34f28ab91d 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-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2014 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 4c20a0974d1..b7e1efca1c9 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -1,8 +1,8 @@ ;;; warnings.el --- log and display warnings -;; Copyright (C) 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2014 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal ;; This file is part of GNU Emacs. @@ -306,9 +306,12 @@ See also `warning-series', `warning-prefix-function' and (set-window-start window warning-series)) (sit-for 0)))))))) +;; Use \\<special-mode-map> so that help-enable-auto-load can do its thing. +;; Any keymap that is defined will do. ;;;###autoload (defun lwarn (type level message &rest args) "Display a warning message made from (format MESSAGE ARGS...). +\\<special-mode-map> Aside from generating the message with `format', this is equivalent to `display-warning'. |