diff options
Diffstat (limited to 'lisp/emacs-lisp')
86 files changed, 13983 insertions, 9536 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 861054e777f..4ee830023fc 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-2015 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 @@ -168,7 +168,8 @@ ;; "Switch to non-existing buffers only upon confirmation." ;; (interactive "BSwitch to buffer: ") ;; (if (or (get-buffer (ad-get-arg 0)) -;; (y-or-n-p (format "`%s' does not exist, create? " (ad-get-arg 0)))) +;; (y-or-n-p (format-message "`%s' does not exist, create? " +;; (ad-get-arg 0)))) ;; ad-do-it)) ;; ;;(defadvice find-file (before existing-files-only activate) @@ -295,8 +296,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 +699,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 +1565,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: @@ -2101,9 +2080,7 @@ mapped to the closest extremal position). If FUNCTION was not advised already, its advice info will be initialized. Redefining a piece of advice whose name is part of -the cache-id will clear the cache. - -See Info node `(elisp)Computed Advice' for detailed documentation." +the cache-id will clear the cache." (cond ((not (ad-is-advised function)) (ad-initialize-advice-info function) (ad-set-advice-info-field @@ -2173,7 +2150,6 @@ See Info node `(elisp)Computed Advice' for detailed documentation." (defun ad-arglist (definition) "Return the argument list of DEFINITION." - (require 'help-fns) (help-function-arglist (if (or (macrop definition) (ad-advice-p definition)) (cdr definition) @@ -2207,26 +2183,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) - (macrop 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. @@ -2463,8 +2419,8 @@ as if they had been supplied to a function with TARGET-ARGLIST directly. Excess source arguments will be neglected, missing source arguments will be supplied as nil. Returns a `funcall' or `apply' form with the second element being `function' which has to be replaced by an actual function argument. -Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return - `(funcall ad--addoit-function a (car args) (car (cdr args)) (nth 2 args))'." +Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return + (funcall ad--addoit-function a (car args) (car (cdr args)) (nth 2 args))." (let* ((parsed-source-arglist (ad-parse-arglist source-arglist)) (source-reqopt-args (append (nth 0 parsed-source-arglist) (nth 1 parsed-source-arglist))) @@ -2518,38 +2474,39 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return (capitalize (symbol-name class)) (ad-advice-name advice))))))) -(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: @@ -2597,7 +2554,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) @@ -2911,6 +2868,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. @@ -3148,7 +3107,7 @@ deactivation, which might run hooks and get into other trouble." "Define a piece of advice for FUNCTION (a symbol). The syntax of `defadvice' is as follows: - \(defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) + (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) [DOCSTRING] [INTERACTIVE-FORM] BODY...) @@ -3186,11 +3145,10 @@ time. This generates a compiled advised definition according to the current advice state that will be used during activation if appropriate. Only use this if the `defadvice' gets actually compiled. -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"] diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el deleted file mode 100644 index 270badd53cb..00000000000 --- a/lisp/emacs-lisp/authors.el +++ /dev/null @@ -1,1097 +0,0 @@ -;;; authors.el --- utility for maintaining Emacs's AUTHORS file -*-coding: utf-8 -*- - -;; Copyright (C) 2000-2013 Free Software Foundation, Inc. - -;; Author: Gerd Moellmann <gerd@gnu.org> -;; Maintainer: Kim F. Storm <storm@cua.dk> -;; Keywords: maint -;; Package: emacs - -;; This file is part of GNU Emacs. - -;; 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: - -;; Use M-x authors RET to create an *Authors* buffer that can used as -;; or merged with Emacs's AUTHORS file. - -;;; Code: - -(defvar authors-coding-system 'utf-8 - "Coding system used in the AUTHORS file.") - -(defconst authors-many-files 20 - "Maximum number of files for which to print individual information. -If an author has modified more files, only the names of the most -frequently modified files are printed and a count of the additional -files.") - -(defconst authors-aliases - '( - ("Aaron S. Hawley" "Aaron Hawley") - ("Alexandru Harsanyi" "Alex Harsanyi") - ("Andrew Csillag" "Drew Csillag") - ("Anna M. Bigatti" "Anna Bigatti") - ("Barry A. Warsaw" "Barry A. Warsaw, Century Computing, Inc." - "Barry A. Warsaw, ITB" "Barry Warsaw") - ("Bill Carpenter" "WJ Carpenter") - ("Bill Mann" "William F. Mann") - ("Bill Rozas" "Guillermo J. Rozas") - ("Björn Torkelsson" "Bjorn Torkelsson") - ("Brian Fox" "Brian J. Fox") - ("Brian Sniffen" "Brian T. Sniffen") - ("Christoph Wedler" "Christoph.Wedler@sap.com") - ("Daniel Pfeiffer" "<Daniel.Pfeiffer@Informatik.START.db.de>" - "<Daniel.Pfeiffer@Informatik.START.dbp.de>") - ("David Abrahams" "Dave Abrahams") - ("David De La Harpe Golden" "David Golden") - ("David Gillespie" "Dave Gillespie") - ("David Kågedal" "David K..edal") - ("David M. Koppelman" "David M. Koppelman, Koppel@Ec?e.Lsu.Edu" - "David Koppelman") - ("David M. Smith" "David Smith" "David M Smith") - ("David O'Toole" "David T. O'Toole") - ("Deepak Goel" "D. Goel") - ("Ed L. Cashin" "Ed L Cashin") - ("Edward M. Reingold" "Ed Reingold" "Edward M Reingold" - "Reingold Edward M") - ("Eli Zaretskii" "eliz") - ("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)") - ("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") - ("Jérôme Marant" "Jérôme Marant" "Jerome Marant") - ("Jens-Ulrik Holger Petersen" "Jens-Ulrik Petersen") - ("Jeremy Bertram Maitin-Shepard" "Jeremy Maitin-Shepard") - ("Johan Bockgård" "Johan Bockgard") - ("John J Foerch" "John Foerch") - ("John W. Eaton" "John Eaton") - ("Jonathan I. Kamens" "Jonathan Kamens") - ("Joseph Arceneaux" "Joe Arceneaux") - ("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") - ("Karl Berry" "K. Berry") - ("Károly Lőrentey" "Károly Lőrentey" "Lőrentey Károly") - ("Kazushi Marukawa" "Kazushi") - ("Ken Manheimer" "Kenneth Manheimer") - ("Kenichi Handa" "Ken'ichi Handa" "Kenichi 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") - ("Marko Kohtala" "Kohtala Marko") - ("Agustín Martín" "Agustin Martin" "Agustín Martín Domingo") - ("Martin Lorentzon" "Martin Lorentzson") - ("Matt Swift" "Matthew Swift") - ("Maxime Edouard Robert Froumentin" "Max Froumentin") - ("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 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") - ("Pavel Kobiakov" "Pavel Kobyakov") - ("Per Abrahamsen" "Per Abhiddenware") - ("Per Starbäck" "Per Starback") - ("Peter J. Weisberg" "PJ Weisberg") - ("Peter S. Galbraith" "Peter Galbraith") - ("Peter Runestig" "Peter 'luna' Runestig") - ("Peter S. Galbraith" "Peter S Galbraith") - ("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") - ("Robert J. Chassell" "Bob Chassell") - ("Roland B. Roberts" "Roland B Roberts" "Roland Roberts") - ("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") - ("T.V. Raman" "T\\. V\\. Raman") - ("Taichi Kawabata" "KAWABATA,? Taichi") - ("Takaaki Ota" "Tak Ota") - ("Takahashi Naoto" "Naoto Takahashi") - ("Teodor Zlatanov" "Ted Zlatanov") - ("Thomas Dye" "Tom Dye") - ("Thomas Horsley" "Tom Horsley") ; FIXME ? - ("Thomas Wurgler" "Tom Wurgler") - ("Toby Cubitt" "Toby S\\. Cubitt") - ("Tomohiko Morioka" "MORIOKA Tomohiko") - ("Torbjörn Axelsson" "Torbjvrn Axelsson") - ("Torbjörn Einarsson" "Torbj.*rn Einarsson") - ("Toru Tomabechi" "Toru Tomabechi,") - ("Tsugutomo Enami" "enami tsugutomo") - ("Ulrich Müller" "Ulrich Mueller") - ("Vincent Del Vecchio" "Vince Del Vecchio") - ("William M. Perry" "Bill Perry") - ("Wlodzimierz Bzyl" "W.*dek Bzyl") - ("Yoni Rabkin" "Yoni Rabkin Katzenell") - ("Yoshinori Koseki" "KOSEKI Yoshinori" "小関 吉則") - ("Yutaka NIIBE" "NIIBE Yutaka") - ) - "Alist of author aliases. - -Each entry is of the form (REALNAME REGEXP...). If an author's name -matches one of the REGEXPs, use REALNAME instead. -If REALNAME is nil, ignore that author.") - -;; FIXME seems it would be less fragile to check for O', Mc, etc. -(defconst authors-fixed-case - '("Bryan O'Sullivan" - "Christian von Roques" - "Christophe de Dinechin" - "Craig McDaniel" - "David J. MacKenzie" - "David McCabe" - "David O'Toole" - "Devon Sean McCullough" - "Dominique de Waleffe" - "Edward O'Connor" - "Exal de Jesus Garcia Carrillo" - "Greg McGary" - "Hans de Graaff" - "James TD Smith" - "Joel N. Weber II" - "Michael McNamara" - "Mike McEwan" - "Nelson Jose dos Santos Ferreira" - "Peter von der Ahe" - "Peter O'Gorman" - "Piet van Oostrum" - "Roland McGrath" - "Sean O'Halpin" - "Sean O'Rourke" - "Tijs van Bakel") - "List of authors whose names cannot be simply capitalized.") - -(defvar authors-public-domain-files - '("emerge\\.el" - "vi\\.el" - "feedmail\\.el" - "mailpost\\.el" - "hanoi\\.el" - "meese\\.el" - "studly\\.el" - "modula2\\.el" - "nnmaildir\\.el" - "nnil\\.el" - "b2m\\.c" - "unexhp9k800\\.c" - "emacsclient\\.1" - "check-doc-strings") - "List of regexps matching files for which the FSF doesn't need papers.") - - -(defvar authors-obsolete-files-regexps - '("vc-\\*\\.el$" - "spec.txt$" - ".*loaddefs.el$" ; not obsolete, but auto-generated - "\\.\\(cvs\\|git\\)ignore$" ; obsolete or uninteresting - "\\.arch-inventory$" - ;; TODO lib/? Matches other things? - "build-aux/" "m4/" "Emacs.xcodeproj" "charsets" "mapfiles" - "preferences\\.\\(nib\\|gorm\\)" - "vc-\\(rcs\\|cvs\\|sccs\\)-hooks\\.el$") - "List of regexps matching obsolete files. -Changes to files matching one of the regexps in this list are not listed.") - -(defconst authors-ignored-files - '("external-lisp" - "lock" "share-lib" "local-lisp" - "noleim-Makefile.in" - "NEWS" "ORDERS" "PROBLEMS" "FAQ" "AUTHORS" "FOR-RELEASE" "TODO" "todo" - "MACHINES" "SERVICE" - "README.unicode" "README.multi-tty" "TUTORIAL.translators" - "NEWS.unicode" "COPYING.DJ" "Makefile.old" "Makefile.am" - "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" - "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" - "js2-mode.el" ; only installed very briefly, replaced by js.el - "cedet/tests/testtemplates.cpp" - "cedet/tests/testusing.cpp" - "cedet/tests/scopetest.cpp" - "cedet/tests/scopetest.java" - "cedet/tests/test.cpp" - "cedet/tests/test.py" - "cedet/tests/teststruct.cpp" - "*.el" - ;; Autogen: - "cus-load.el" "finder-inf.el" "ldefs-boot.el" - "compile" "config.guess" "config.sub" "depcomp" - ;; Only existed briefly, then renamed: - "images/icons/allout-widgets-dark-bg" - "images/icons/allout-widgets-light-bg" - ;; Never had any meaningful changes logged, now deleted: - "unidata/bidimirror.awk" "unidata/biditype.awk" - "split-man" "Xkeymap.txt" "ms-7bkermit" "ulimit.hack" - "gnu-hp300" "refcard.bit" "ledit.l" "forms.README" "forms-d2.dat" - "CXTERM-DIC/PY.tit" "CXTERM-DIC/ZIRANMA.tit" - "CXTERM-DIC/CTLau.tit" "CXTERM-DIC/CTLauB.tit" - "NICKLES.WORTH" "INTERVAL.IDEAS" "RCP" - "3B-MAXMEM" "AIX.DUMP" "SUN-SUPPORT" "XENIX" - "CODINGS" "CHARSETS" - "calc/INSTALL" "calc/Makefile" - "vms-pp.trans" "_emacs" "batcomp.com" "notes/cpp" ; admin/ - "emacsver.texi.in" - "vpath.sed" - "Cocoa/Emacs.base/Contents/Info.plist" - "Cocoa/Emacs.base/Contents/Resources/English.lproj/InfoPlist.strings" - "GNUstep/Emacs.base/Resources/Info-gnustep.plist" - "GNUstep/Emacs.base/Resources/Emacs.desktop" - "Cocoa/Emacs.base/Contents/Resources/English.lproj" - ;; Only existed briefly, then deleted: - "coccinelle/overlay.cocci" "coccinelle/symbol.cocci" - ;; MH-E stuff not in Emacs: - "import-emacs" "release-utils" - ;; Erc stuff not in Emacs: - "ChangeLog.2001" "ChangeLog.2002" "ChangeLog.2003" "ChangeLog.2004" - "ChangeLog.2005" - "README.extras" "dir-template" "mkChangeLog" "MkChangeLog" "erc-auto.in" - "CREDITS" "HACKING" - "debian/changelog" - "debian/control" - "debian/copyright" - "debian/maint/conffiles" - "debian/maint/conffiles.in" - "debian/maint/postinst" - "debian/maint/postinst.in" - "debian/maint/prerm" - "debian/maint/prerm.in" - "debian/README.Debian" - "debian/README.erc-speak" - "debian/rules" - "debian/scripts/install" - "debian/scripts/install.in" - "debian/scripts/remove" - "debian/scripts/remove.in" - "debian/scripts/startup" - "debian/scripts/startup.erc" - "debian/scripts/startup.erc-speak" - ) - "List of files and directories to ignore. -Changes to files in this list are not listed.") - -;; List via: find . -name '*.el' | sed 's/.*\///g' | sort | uniq -d -;; FIXME It would be better to discover these dynamically. -;; Note that traditionally "Makefile.in" etc have not been in this list. -;; Ditto for "abbrev.texi" etc. -(defconst authors-ambiguous-files - '("chart.el" - "compile.el" - "complete.el" - "cpp.el" - "ctxt.el" - "custom.el" - "cyrillic.el" - "czech.el" - "debug.el" - "dired.el" - "el.el" - "eshell.el" - "ethiopic.el" - "f90.el" - "files.el" - "find.el" - "format.el" - "generic.el" - "georgian.el" - "greek.el" - "grep.el" - "hebrew.el" - "imenu.el" - "indian.el" - "japanese.el" - "java.el" - "lao.el" - "linux.el" - "locate.el" - "make.el" - "mode.el" - "python.el" - "rmailmm.el" - "semantic.el" - "shell.el" - "simple.el" - "slovak.el" - "sort.el" - "speedbar.el" - "srecode.el" - "table.el" - "texi.el" - "thai.el" - "tibetan.el" - "util.el" - "vc-bzr.el" - "wisent.el") - "List of basenames occurring more than once in the source.") - -;; FIXME :cowrote entries here can be overwritten by :wrote entries -;; derived from a file's Author: header (eg mh-e). This really means -;; the Author: header is erroneous. -(defconst authors-fixed-entries - '(("Richard M. Stallman" :wrote "[The original GNU Emacs and numerous files]") - ("Joseph Arceneaux" :wrote "xrdb.c") - ;; This refers to the obsolete Willisson (qv) version. -;;; ("Blitz Product Development Corporation" :wrote "ispell.el") - ("Frank Bresz" :wrote "diff.el") - ("David M. Brown" :wrote "array.el") - ;; No longer distributed. -;;; ("Gary Byers" :changed "xenix.h") - ("Shawn M. Carey" :wrote "freebsd.h") - ;; 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") - ("Lawrence R. Dodd" :cowrote "dired-x.el") - ;; No longer distributed. -;;; ("Viktor Dukhovni" :wrote "unexsunos4.c") - ("Paul Eggert" :wrote "rcs2log") ; "vcdiff" - ("Fred Fish" :changed "unexcoff.c") - ;; No longer distributed. -;;; ("Tim Fleehart" :wrote "makefile.nt") - ("Keith Gabryelski" :wrote "hexl.c") - ("Kevin Gallagher" :wrote "flow-ctrl.el") - ;; Also wrote an earlier version of disp-table.el, since replaced - ;; by Erik Naggum's version; also iso-syntax.el, later renamed to - ;; latin-1.el, since deleted. - ("Howard Gayle" :wrote "casetab.c") - ;; :wrote mh-pick.el, since merged into mh-search.el. - ;; Originally wrote mh-funcs.el, but it has been rewritten since. - ("Stephen Gildea" :wrote "refcard.tex" - :cowrote "mh-funcs.el" "mh-search.el") - ;; cl.texinfo renamed to cl.texi. - ("David Gillespie" :wrote "cl.texi") - ;; No longer distributed: emacsserver.c. - ("Hewlett-Packard" :changed "emacsclient.c" "server.el" "keyboard.c") - ;; No longer distributed. -;;; ("Thomas Horsley" :wrote "cxux.h" "cxux7.h") - ("Indiana University Foundation" :changed "buffer.c" "buffer.h" - "indent.c" "search.c" "xdisp.c" "region-cache.c" "region-cache.h") - ;; ibmrt.h, ibmrt-aix.h no longer distributed. - ("International Business Machines" :changed "emacs.c" "fileio.c" - "process.c" "sysdep.c" "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. -;;; ("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") - ("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") - ("Sebastian Kremer" :changed "add-log.el") - ("Mark Lambert" :changed "process.c" "process.h") - ("Aaron Larson" :changed "bibtex.el") - ;; It was :wrote, but it has been rewritten since. - ("James R. Larus" :cowrote "mh-e.el") - ("Lars Lindberg" :changed "dabbrev.el" :cowrote "imenu.el") - ;; No longer distributed: lselect.el. - ("Lucid, Inc." :changed "bytecode.c" "byte-opt.el" "byte-run.el" - "bytecomp.el" "delsel.el" "disass.el" "faces.el" "font-lock.el" - "lmenu.el" "mailabbrev.el" "select.el" "xfaces.c" "xselect.c") - ;; MCC. No longer distributed: emacsserver.c. - ("Microelectronics and Computer Technology Corporation" - :changed "etags.c" "emacsclient.c" "movemail.c" - "rmail.el" "rmailedit.el" "rmailkwd.el" - "rmailmsc.el" "rmailout.el" "rmailsum.el" "scribe.el" - ;; It was :wrote for xmenu.c, but it has been rewritten since. - "server.el" "lisp.h" "sysdep.c" "unexcoff.c" "xmenu.c") - ("Niall Mansfield" :changed "etags.c") - ("Brian Marick" :cowrote "hideif.el") - ("Marko Kohtala" :changed "info.el") - ("Sidney Markowitz" :changed "doctor.el") - ;; No longer distributed: env.c. - ("Richard Mlynarik" :wrote "ehelp.el") - ("Mosur Mohan" :changed "etags.c") - ("Jeff Morgenthaler" :changed "flow-ctrl.el" "vt200.el" "vt201.el" - "vt220.el" "vt240.el") - ("Motorola" :changed "buff-menu.el") - ("Hiroshi Nakano" :changed "ralloc.c") - ;; File removed in Emacs 24.1. -;;; ("Sundar Narasimhan" :changed "rnewspost.el") - ;; No longer distributed. -;;; ("NeXT, Inc." :wrote "unexnext.c") - ("Mark Neale" :changed "fortran.el") - ;; Renamed from sc.el. - ("Martin Neitzel" :changed "supercite.el") - ("Andrew Oram" :changed "calendar.texi (and other files in man/)") - ("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") - ("Roland B. Roberts" :changed "files.el" "sort.el" - "buffer.h" "callproc.c" "dired.c" "process.c" "sysdep.c" "systty.h") - ;; No longer distributed. -;;; "vmspaths.h" "build.com" "compile.com" "kepteditor.com" "precomp.com" -;;; "vmsproc.el" :wrote "logout.com" "mailemacs.com") -;;; ("Guillermo J. Rozas" :wrote "fakemail.c") - ("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" - "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: emacsserver.c. - ("William Sommerfeld" :wrote "emacsclient.c" "scribe.el") - ;; No longer distributed: emacsserver.c. - ("Leigh Stoller" :changed "emacsclient.c" "server.el") - ("Steve Strassmann" :wrote "spook.el") - ("Shinichirou Sugou" :changed "etags.c") - ;; No longer distributed: emacsserver.c. - ("Sun Microsystems, Inc" :changed "emacsclient.c" "server.el" - :wrote "emacs.icon" "sun.el") - ;; No longer distributed. -;;; "emacstool.1" "emacstool.c" "sun-curs.el" -;;; "sun-fns.el" "sun-mouse.el" "sunfns.c") - ;; Renamed from sc.el. - ("Kayvan Sylvan" :changed "supercite.el") - ;; No longer distributed: emacsserver.c, tcp.c. - ("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: 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; - ;; ntproc.c to w32proc.c; ntterm.c to w32term.c; - ;; windowsnt.h to ms-w32.h. - ("Geoff Voelker" :wrote "w32-fns.el" "w32.c" "w32.h" "w32heap.c" - "w32heap.h" "w32inevt.c" "w32proc.c" "w32term.c" "ms-w32.h") - ("Morten Welinder" :wrote "dosfns.c" "[many MS-DOS files]" "msdos.h") - ("Eli Zaretskii" :wrote "bidi.c" "[bidirectional display in xdisp.c]") - ;; Not using this version any more. -;;; ("Pace Willisson" :wrote "ispell.el") - ;; FIXME overwritten by Author:. - ("Bill Wohler" :cowrote "mh-e.el") - ("Garrett Wollman" :changed "sendmail.el") - ("Dale R. Worley" :changed "mail-extr.el") - ("Jamie Zawinski" :changed "bytecode.c" :wrote "tar-mode.el" - :cowrote "disass.el")) - "Actions taken from the original, manually (un)maintained AUTHORS file.") - - -(defconst authors-valid-file-names - '("aclocal.m4" - "build-ins.in" - "Makefile.noleim" - "makedist.bat" - "makefile.def" - "makefile.nt" - "ns.mk" - "debug.bat.in" "emacs.bat.in" - ".gdbinit-union" - "alloca.s" - "make-delta" - "config.w95" - "emacstool.1" - "align.umax" - "cxux-crt0.s" - "gould-sigvec.s" - "getdate.y" - "ymakefile" - "permute-index" "index.perm" - "ibmrs6000.inp" - "b2m.c" "b2m.1" "b2m.pl" "rcs-checkin.1" - "emacs.bash" "emacs.csh" "ms-kermit" - "emacs.ico" - "emacs21.ico" - "emacs.py" "emacs2.py" "emacs3.py" - "BABYL" "LPF" "LEDIT" "OTHER.EMACSES" - "emacs16_mac.png" "emacs24_mac.png" - "emacs256_mac.png" "emacs32_mac.png" - "emacs48_mac.png" "emacs512_mac.png" - "revdiff" ; admin/ - "vcdiff" "rcs-checkin" "tindex.pl" - "mainmake" "sed1.inp" "sed2.inp" "sed3.inp" ; msdos/ - "mac-fix-env.m" - ;; Deleted vms stuff: - "temacs.opt" "descrip.mms" "compile.com" "link.com" - ) - "File names which are valid, but no longer exist (or cannot be found) -in the repository.") - -(defconst authors-renamed-files-alist - '(("nt.c" . "w32.c") ("nt.h" . "w32.h") - ("ntheap.c" . "w32heap.c") ("ntheap.h" . "w32heap.h") - ("ntinevt.c" . "w32inevt.c") ("ntinevt.h" . "w32inevt.h") - ("ntproc.c" . "w32proc.c") - ("w32console.c" . "w32term.c") - ("unexnt.c" . "unexw32.c") - ("s/windowsnt.h" . "s/ms-w32.h") - ("s/ms-w32.h" . "inc/ms-w32.h") - ("winnt.el" . "w32-fns.el") - ("emacs.manifest" . "emacs-x86.manifest") - ("config.emacs" . "configure") - ("configure.in" . "configure.ac") - ("config.h.dist" . "config.in") - ("config.h-dist" . "config.in") - ("config.h.in" . "config.in") - ("paths.h-dist" . "paths.h.in") - ("patch1" . "sed1.inp") - ("GETTING.GNU.SOFTWARE" . "FTP") - ("etc/MACHINES" . "MACHINES") - ("ONEWS" . "NEWS.19") - ("ONEWS.1" . "NEWS.1-17") - ("ONEWS.2" . "NEWS.1-17") - ("ONEWS.3" . "NEWS.18") - ("ONEWS.4" . "NEWS.18") - ("ORDERS.USA" . "ORDERS") - ("EUROPE" . "ORDERS") - ("DIFF" . "OTHER.EMACSES") - ("CCADIFF" . "OTHER.EMACSES") - ("GOSDIFF" . "OTHER.EMACSES") - ("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") - ;; 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") - ("build-install" . "build-ins.in") - ("build-install.in" . "build-ins.in") - ("unidata/Makefile" . "unidata/Makefile.in") - ("move-if-change" . "build-aux/move-if-change") - ("update-subdirs" . "build-aux/update-subdirs") - ;; Not renamed, but we only have the latter in the Emacs repo. - ("trampver.texi.in" . "trampver.texi") - ("e/eterm" . "e/eterm-color") - ("e/eterm.ti" . "e/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") - ("edt-user.doc" . "edt.texi") - ("DEV-NOTES" . "nextstep") - ("org/COPYRIGHT-AND-LICENSE" . "org/README") - ;; Moved to different directories. - ("ctags.1" . "ctags.1") - ("etags.1" . "etags.1") - ("emacs.1" . "emacs.1") - ("emacsclient.1" . "emacsclient.1") - ("icons/emacs21.ico" . "emacs21.ico") - ;; Moved from admin/nt/ to nt/. - ("nt/README.W32" . "README.W32") - ) - "Alist of files which have been renamed during their lifetime. -Elements are (OLDNAME . NEWNAME).") - -(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\\)$" . - "images/\\1") - ("^\\(images/icons/\\)mac\\(emacs\\)_\\([0-9]+\\)\\(\\.png\\)" . - "\\1\\2\\3_mac\\4") - ("\\(images/icons/\\)emacs_\\([0-9][0-9]\\)\\.png" . - "\\1hicolor/\\2x\\2/apps/emacs.png") - ) - "List regexps and rewriting rules for renamed files. -Elements are (REGEXP . REPLACE). 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.") - -(defvar authors-checked-files-alist) -(defvar authors-invalid-file-names) - -(defun authors-disambiguate-file-name (fullname) - "Convert FULLNAME to an unambiguous relative-name." - (let ((relname (file-name-nondirectory fullname)) - parent) - (if (member relname authors-ambiguous-files) - ;; In case of ambiguity, just prepend the parent directory. - ;; FIXME obviously this is not a perfect solution. - (if (string-equal "lisp" - (setq parent (file-name-nondirectory - (directory-file-name - (file-name-directory fullname))))) - relname - (format "%s/%s" parent relname)) - relname))) - -(defun authors-canonical-file-name (file log-file pos author) - "Return canonical file name for FILE found in LOG-FILE. -Checks whether FILE is a valid (existing) file name, has been renamed, -or is on the list of removed files. Returns the non-directory part of -the file name. Only uses the LOG-FILE position POS and associated AUTHOR -to print a message if FILE is not found." - ;; FILE should be re-checked in every different directory associated - ;; with a LOG-FILE. Eg configure.ac from src/ChangeLog is not the - ;; same as that from top-level/ChangeLog. - (let* ((fullname (expand-file-name file (file-name-directory log-file))) - (entry (assoc fullname authors-checked-files-alist)) - relname - valid) - (if entry - (cdr entry) - (setq relname (file-name-nondirectory file)) - (if (or (member relname authors-valid-file-names) - (file-exists-p file) - (file-exists-p relname) - (file-exists-p (concat "etc/" relname))) - (setq valid (authors-disambiguate-file-name fullname)) - (setq valid (assoc file authors-renamed-files-alist)) - (if valid - (setq valid (cdr valid)) - (let ((rules authors-renamed-files-regexps)) - (while rules - (if (string-match (car (car rules)) file) - (setq valid (if (stringp (cdr (car rules))) - (file-name-nondirectory - (replace-match (cdr (car rules)) t nil file)) - relname) - 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)) - (setq authors-invalid-file-names - (cons (format "%s:%d: unrecognized `%s' for %s" - log-file - (1+ (count-lines (point-min) pos)) - file author) - authors-invalid-file-names))) - valid))) - -(defun authors-add-fixed-entries (table) - "Add actions from `authors-fixed-entries' to TABLE." - (dolist (entry authors-fixed-entries) - (let ((author (car entry)) - action) - (dolist (item (cdr entry)) - (if (symbolp item) - (setq action item) - (authors-add author item action table)))))) - - -(defun authors-obsolete-file-p (file) - "Return non-nil if FILE is obsolete. -FILE is considered obsolete if it matches one of the regular expressions -from `authors-obsolete-files-regexps'." - (let (obsolete-p - (regexps authors-obsolete-files-regexps)) - (while (and regexps (not obsolete-p)) - (setq obsolete-p (string-match (car regexps) file) - regexps (cdr regexps))) - obsolete-p)) - - -(defun authors-add (author file action table) - "Record that AUTHOR worked on FILE. -ACTION is a keyword symbol describing what he did. Record file, -author and what he did in hash table TABLE. See the description of -`authors-scan-change-log' for the structure of the hash table." - (unless (or (member file authors-ignored-files) - (authors-obsolete-file-p file) - (equal author "")) - (let* ((value (gethash author table)) - (entry (assoc file value)) - slot) - (if (null entry) - (puthash author (cons (list file (cons action 1)) value) table) - (if (setq slot (assoc action (cdr entry))) - (setcdr slot (1+ (cdr slot))) - (nconc entry (list (cons action 1)))))))) - - -(defun authors-canonical-author-name (author) - "Return a canonicalized form of AUTHOR, an author name. -If AUTHOR has an entry in `authors-aliases', use that. Remove -email addresses. Capitalize words in the author's name, unless -it is found in `authors-fixed-case'." - (let* ((aliases authors-aliases) - regexps realname) - (while aliases - (setq realname (car (car aliases)) - regexps (cdr (car aliases)) - aliases (cdr aliases)) - (while regexps - (if (string-match (car regexps) author) - (setq author realname - regexps nil - aliases nil) - (setq regexps (cdr regexps)))))) - (when author - (setq author (replace-regexp-in-string "[ \t]*[(<].*$" "" author)) - (setq author (replace-regexp-in-string "\`[ \t]+" "" author)) - (setq author (replace-regexp-in-string "[ \t]+$" "" author)) - (setq author (replace-regexp-in-string "[ \t]+" " " author)) - (unless (string-match "[-, \t]" author) - (setq author "")) - (or (car (member author authors-fixed-case)) - (capitalize author)))) - -(defun authors-scan-change-log (log-file table) - "Scan change log LOG-FILE for author information. - -For each change mentioned in the log, add an entry to hash table TABLE -under the author's canonical name. - -Keys of TABLE are author names. Values are alists of entries (FILE -\(ACTION . COUNT) ...). FILE is one file the author worked on. The -rest of the entry is a list of keyword symbols describing what he did -with the file and the number of each action: - -:wrote means the author wrote the file -:cowrote means he wrote the file in collaboration with others -:changed means he changed the file COUNT times." - - (let* ((enable-local-variables :safe) ; for find-file, hence let* - (enable-local-eval nil) - (existing-buffer (get-file-buffer log-file)) - (buffer (find-file-noselect log-file)) - authors pos) - (with-current-buffer buffer - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward "^[0-9]\\|^[ \t]+\\* " nil t) - (beginning-of-line) - (setq pos (point)) - (cond ((looking-at "^[0-9]+-[0-9]+-[0-9]+") - ;; Handle joint authorship of changes. - ;; This can be a bit fragile, and is not too common. - (setq authors nil) - (while (progn - (skip-chars-forward " \t+:0-9-") - (not (looking-at "\\($\\|\\*\\|\ -Suggested\\|Trivial\\|Version\\|Originally\\|From:\\|Patch[ \t]+[Bb]y\\)"))) - (push (authors-canonical-author-name - (buffer-substring-no-properties - (point) (line-end-position))) authors) - (forward-line 1))) - ((looking-at "^[ \t]+\\*") - (let ((line (buffer-substring-no-properties - (match-end 0) (line-end-position)))) - (while (and (not (string-match ":" line)) - (forward-line 1) - (not (looking-at ":\\|^[ \t]*$"))) - (setq line (concat line - (buffer-substring-no-properties - (line-beginning-position) - (line-end-position))))) - (when (string-match ":" line) - (setq line (substring line 0 (match-beginning 0))) - (setq line (replace-regexp-in-string "[[(<{].*$" "" line)) - (setq line (replace-regexp-in-string "," "" line)) - (dolist (file (split-string line)) - (when (setq file (authors-canonical-file-name file log-file pos (car authors))) - (dolist (author authors) - ;;(message "%s changed %s" author file) - (authors-add author file :changed table))))) - (forward-line 1))))))) - (unless existing-buffer - (kill-buffer buffer)))) - - -(defun authors-scan-el (file table) - "Scan Lisp file FILE for author information. -TABLE is a hash table to add author information to." - (let* ((existing-buffer (get-file-buffer file)) - (enable-local-variables :safe) ; for find-file, hence let* - (enable-local-eval nil) - (buffer (find-file-noselect file))) - (setq file (authors-disambiguate-file-name (expand-file-name file))) - (with-current-buffer buffer - (save-restriction - (widen) - (goto-char (point-min)) - (while (and (re-search-forward - "^;+[ \t]*\\(Authors?\\|Commentary\\|Code\\):[ \t]*" nil t) - (not (member (match-string 1) '("Commentary" "Code")))) - (let ((continue t) - (action :wrote) - authors) - (while continue - ;; Some entries contain a year range in front of the - ;; author's name. - (skip-chars-forward "-0-9 \t") - (push (authors-canonical-author-name - (buffer-substring-no-properties - (point) (line-end-position))) authors) - ;; tips.texi says the continuation line should begin - ;; with a tab, but often spaces are used. - (setq continue - (and (zerop (forward-line 1)) - (looking-at ";;;?\\(\t+ *\\| +\\)[[:alnum:]]") - (goto-char (1- (match-end 0))) - (not (looking-at "[[:upper:]][-[:alpha:]]+:[ \t]"))))) - (and (> (length authors) 1) - (setq action :cowrote)) - (mapc (lambda (author) - (authors-add author file action table)) - authors))))) - (unless existing-buffer - (kill-buffer buffer)))) - - -(defun authors-public-domain-p (file) - "Return t if FILE is a file that was put in public domain." - (let ((public-domain-p nil) - (list authors-public-domain-files)) - (while (and list (not public-domain-p)) - (when (string-match (car list) file) - (setq public-domain-p t)) - (setq list (cdr list))) - public-domain-p)) - -(defvar authors-author-list) - -(defun authors-add-to-author-list (author changes) - "Insert information about AUTHOR's work on Emacs into `authors-author-list'. -CHANGES is an alist of entries (FILE (ACTION . COUNT) ...), as produced by -`authors-scan-change-log'. -The element added to `authors-author-list' is (AUTHOR WROTE CO-WROTE CHANGED), -where WROTE, CO-WROTE, and CHANGED are lists of the files written, co-written -and changed by AUTHOR." - (when author - (let ((nchanged 0) - wrote-list - cowrote-list - changed-list) - (dolist (change changes) - (let* ((actions (cdr change)) - (file (car change)) - (filestat (if (authors-public-domain-p file) - (concat file " (public domain)") - file))) - (cond ((assq :wrote actions) - (setq wrote-list (cons filestat wrote-list))) - ((assq :cowrote actions) - (setq cowrote-list (cons filestat cowrote-list))) - (t - (setq changed-list - (cons (cons file (cdr (assq :changed actions))) - changed-list)))))) - (if wrote-list - (setq wrote-list (sort wrote-list 'string-lessp))) - (if cowrote-list - (setq cowrote-list (sort cowrote-list 'string-lessp))) - (when changed-list - (setq changed-list (sort changed-list - (lambda (a b) - (if (= (cdr a) (cdr b)) - (string-lessp (car a) (car b)) - (> (cdr a) (cdr b)))))) - (setq nchanged (length changed-list)) - (setq changed-list (mapcar 'car changed-list))) - (if (> (- nchanged authors-many-files) 2) - (setcdr (nthcdr authors-many-files changed-list) - (list (format "and %d other files" (- nchanged authors-many-files))))) - (setq authors-author-list - (cons (list author wrote-list cowrote-list changed-list) - authors-author-list))))) - -(defun authors (root) - "Extract author information from change logs and Lisp source files. -ROOT is the root directory under which to find the files. If called -interactively, ROOT is read from the minibuffer. -Result is a buffer *Authors* containing authorship information, and a -buffer *Authors Errors* containing references to unknown files." - (interactive "DEmacs source directory: ") - (setq root (expand-file-name root)) - (let ((logs (process-lines find-program root "-name" "ChangeLog*")) - (table (make-hash-table :test 'equal)) - (buffer-name "*Authors*") - authors-checked-files-alist - authors-invalid-file-names) - (authors-add-fixed-entries table) - (unless (file-exists-p (expand-file-name "src/emacs.c" root)) - (unless (y-or-n-p - (format "Not the root directory of Emacs: %s, continue? " root)) - (error "Not the root directory"))) - (dolist (log logs) - (when (string-match "ChangeLog\\(.[0-9]+\\)?$" log) - (message "Scanning %s..." log) - (authors-scan-change-log log table))) - (let ((els (process-lines find-program root "-name" "*.el"))) - (dolist (file els) - (message "Scanning %s..." file) - (authors-scan-el file table))) - (message "Generating buffer %s..." buffer-name) - (set-buffer (get-buffer-create buffer-name)) - (erase-buffer) - (set-buffer-file-coding-system authors-coding-system) - (insert -"Many people have contributed code included in the Free Software -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) - (maphash #'authors-add-to-author-list table) - (setq authors-author-list - (sort authors-author-list - (lambda (a b) (string-lessp (car a) (car b))))) - (dolist (a authors-author-list) - (let ((author (car a)) - (wrote (nth 1 a)) - (cowrote (nth 2 a)) - (changed (nth 3 a)) - file) - (insert "\n" author ": ") - (when wrote - (insert "wrote") - (dolist (file wrote) - (if (> (+ (current-column) (length file)) 72) - (insert "\n ")) - (insert " " file)) - (insert "\n")) - (when cowrote - (if wrote - (insert "and ")) - (insert "co-wrote") - (dolist (file cowrote) - (if (> (+ (current-column) (length file)) 72) - (insert "\n ")) - (insert " " file)) - (insert "\n")) - (when changed - (if (or wrote cowrote) - (insert "and ")) - (insert "changed") - (dolist (file changed) - (if (> (+ (current-column) (length file)) 72) - (insert "\n ")) - (insert " " file)) - (insert "\n"))))) - (insert "\nLocal" " Variables:\ncoding: " - (symbol-name authors-coding-system) "\nEnd:\n") - (message "Generating buffer %s... done" buffer-name) - (unless noninteractive - (when authors-invalid-file-names - (with-current-buffer (get-buffer-create "*Authors Errors*") - (setq buffer-read-only nil) - (erase-buffer) - (set-buffer-file-coding-system authors-coding-system) - (insert "Unrecognized file entries found:\n\n") - (mapc (lambda (f) (if (not (string-match "^[A-Za-z]+$" f)) (insert f "\n"))) - (sort authors-invalid-file-names 'string-lessp)) - (goto-char (point-min)) - (compilation-mode) - (message "Errors were found. See buffer %s" (buffer-name)))) - (pop-to-buffer buffer-name)))) - - -(defun batch-update-authors () - "Produce an AUTHORS file. -Call this function in batch mode with two command line arguments FILE -and ROOT. FILE is the file to write, ROOT is the root directory of -the Emacs source tree, from which to build the file." - (unless noninteractive - (error "`batch-update-authors' is to be used only with -batch")) - (when (/= (length command-line-args-left) 2) - (error "Call `batch-update-authors' with the name of the file to write")) - (let* ((file (pop command-line-args-left)) - (root (pop command-line-args-left))) - (authors root) - (write-file file))) - -(provide 'authors) - -;;; authors.el ends here diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index e531bc0bdae..12d0a94127f 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-2015 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Keywords: maint @@ -32,7 +32,6 @@ (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)) (defvar generated-autoload-file nil @@ -120,7 +119,8 @@ expression, in which case we want to handle forms differently." ;; Look for an interactive spec. (interactive (pcase body ((or `((interactive . ,_) . ,_) - `(,_ (interactive . ,_) . ,_)) t)))) + `(,_ (interactive . ,_) . ,_)) + t)))) ;; Add the usage form at the end where describe-function-1 ;; can recover it. (when (listp args) (setq doc (help-add-fundoc-usage doc args))) @@ -140,11 +140,9 @@ expression, in which case we want to handle forms differently." ;; For complex cases, try again on the macro-expansion. ((and (memq car '(easy-mmode-define-global-mode define-global-minor-mode define-globalized-minor-mode defun defmacro - ;; FIXME: we'd want `defmacro*' here as well, so as - ;; to handle its `declare', but when autoload is run - ;; CL is not loaded so macroexpand doesn't know how - ;; to expand it! - easy-mmode-define-minor-mode define-minor-mode)) + easy-mmode-define-minor-mode define-minor-mode + define-inline cl-defun cl-defmacro)) + (macrop car) (setq expand (let ((load-file-name file)) (macroexpand form))) (memq (car expand) '(progn prog1 defalias))) (make-autoload expand file 'expansion)) ;Recurse on the expansion. @@ -236,8 +234,9 @@ If a buffer is visiting the desired autoload file, return it." (enable-local-eval nil)) ;; We used to use `raw-text' to read this file, but this causes ;; problems when the file contains non-ASCII characters. - (find-file-noselect - (autoload-ensure-default-file (autoload-generated-file))))) + (let ((delay-mode-hooks t)) + (find-file-noselect + (autoload-ensure-default-file (autoload-generated-file)))))) (defun autoload-generated-file () (expand-file-name generated-autoload-file @@ -351,9 +350,26 @@ not be relied upon." ";;; " basename " ends here\n"))) +(defvar autoload-ensure-writable nil + "Non-nil means `autoload-ensure-default-file' makes existing file writable.") +;; Just in case someone tries to get you to overwrite a file that you +;; don't want to. +;;;###autoload +(put 'autoload-ensure-writable 'risky-local-variable t) + (defun autoload-ensure-default-file (file) - "Make sure that the autoload file FILE exists and if not create it." - (unless (file-exists-p file) + "Make sure that the autoload file FILE exists, creating it if needed. +If the file already exists and `autoload-ensure-writable' is non-nil, +make it writable." + (if (file-exists-p file) + ;; Probably pointless, but replaces the old AUTOGEN_VCS in lisp/Makefile, + ;; which was designed to handle CVSREAD=1 and equivalent. + (and autoload-ensure-writable + (let ((modes (file-modes file))) + (if (zerop (logand modes #o0200)) + ;; Ignore any errors here, and let subsequent attempts + ;; to write the file raise any real error. + (ignore-errors (set-file-modes file (logior modes #o0200)))))) (write-region (autoload-rubric file) nil file)) file) @@ -384,7 +400,7 @@ which lists the file name and which functions are in it, etc." (erase-buffer) (setq buffer-undo-list t buffer-read-only nil) - (emacs-lisp-mode) + (delay-mode-hooks (emacs-lisp-mode)) (setq default-directory (file-name-directory file)) (insert-file-contents file nil) (let ((enable-local-variables :safe) @@ -506,112 +522,132 @@ If OUTFILE is non-nil and FILE specifies a `generated-autoload-file' 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 (load-name - (print-length nil) - (print-level nil) - (print-readably t) ; This does something in Lucid Emacs. - (float-output-format nil) - (visited (get-file-buffer file)) - (otherbuf nil) - (absfile (expand-file-name file)) - ;; nil until we found a cookie. - output-start) - (with-current-buffer (or visited - ;; It is faster to avoid visiting the file. - (autoload-find-file file)) - ;; Obey the no-update-autoloads file local variable. - (unless no-update-autoloads - (message "Generating autoloads for %s..." file) - (setq load-name - (if (stringp generated-autoload-load-name) - generated-autoload-load-name - (autoload-file-load-name absfile))) - (when (and outfile - (not - (if (memq system-type '(ms-dos windows-nt)) - (equal (downcase outfile) - (downcase (autoload-generated-file))) - (equal outfile (autoload-generated-file))))) - (setq otherbuf t)) - (save-excursion - (save-restriction - (widen) - (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)) - (newline))))) - - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\n\f") - (cond - ((looking-at (regexp-quote generate-autoload-cookie)) - ;; If not done yet, figure out where to insert this text. - (unless 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)) - (t - (forward-sexp 1) - (forward-line 1)))))) - - (when output-start - (let ((secondary-autoloads-file-buf - (if otherbuf (current-buffer)))) - (with-current-buffer (marker-buffer output-start) - (save-excursion - ;; Insert the section-header line which lists the file name - ;; and which functions are in it, etc. - (goto-char output-start) - (let ((relfile (file-relative-name absfile))) - (autoload-insert-section-header - (marker-buffer output-start) - () load-name relfile - (if secondary-autoloads-file-buf - ;; MD5 checksums are much better because they do not - ;; change unless the file changes (so they'll be - ;; equal on two different systems and will change - ;; less often than time-stamps, thus leading to fewer - ;; unneeded changes causing spurious conflicts), but - ;; using time-stamps is a very useful optimization, - ;; so we use time-stamps for the main autoloads file - ;; (loaddefs.el) where we have special ways to - ;; circumvent the "random change problem", and MD5 - ;; checksum in secondary autoload files where we do - ;; not need the time-stamp optimization because it is - ;; already provided by the primary autoloads file. - (md5 secondary-autoloads-file-buf - ;; We'd really want to just use - ;; `emacs-internal' instead. - nil nil 'emacs-mule-unix) - (nth 5 (file-attributes relfile)))) - (insert ";;; Generated autoloads from " relfile "\n"))) - (insert generate-autoload-section-trailer)))) - (message "Generating autoloads for %s...done" file)) - (or visited - ;; We created this buffer, so we should kill it. - (kill-buffer (current-buffer)))) - (or (not output-start) - ;; If the entries were added to some other buffer, then the file - ;; doesn't add entries to OUTFILE. - otherbuf)))) +\(or OUTBUF if OUTFILE is nil). The actual return value is +FILE's modification time." + ;; Include the file name in any error messages + (condition-case err + (let (load-name + (print-length nil) + (print-level nil) + (print-readably t) ; This does something in Lucid Emacs. + (float-output-format nil) + (visited (get-file-buffer file)) + (otherbuf nil) + (absfile (expand-file-name file)) + ;; nil until we found a cookie. + output-start) + (when + (catch 'done + (with-current-buffer (or visited + ;; It is faster to avoid visiting the file. + (autoload-find-file file)) + ;; Obey the no-update-autoloads file local variable. + (unless no-update-autoloads + (or noninteractive (message "Generating autoloads for %s..." file)) + (setq load-name + (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)) + (equal (downcase outfile) + (downcase (autoload-generated-file))) + (equal outfile (autoload-generated-file))))) + (setq otherbuf t)) + (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") + (cond + ((looking-at (regexp-quote generate-autoload-cookie)) + ;; If not done yet, figure out where to insert this text. + (unless 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)) + (t + (forward-sexp 1) + (forward-line 1)))))) + + (when output-start + (let ((secondary-autoloads-file-buf + (if otherbuf (current-buffer)))) + (with-current-buffer (marker-buffer output-start) + (save-excursion + ;; Insert the section-header line which lists the file name + ;; and which functions are in it, etc. + (goto-char output-start) + (let ((relfile (file-relative-name absfile))) + (autoload-insert-section-header + (marker-buffer output-start) + () load-name relfile + (if secondary-autoloads-file-buf + ;; MD5 checksums are much better because they do not + ;; change unless the file changes (so they'll be + ;; equal on two different systems and will change + ;; less often than time-stamps, thus leading to fewer + ;; unneeded changes causing spurious conflicts), but + ;; using time-stamps is a very useful optimization, + ;; so we use time-stamps for the main autoloads file + ;; (loaddefs.el) where we have special ways to + ;; circumvent the "random change problem", and MD5 + ;; checksum in secondary autoload files where we do + ;; not need the time-stamp optimization because it is + ;; already provided by the primary autoloads file. + (md5 secondary-autoloads-file-buf + ;; We'd really want to just use + ;; `emacs-internal' instead. + nil nil 'emacs-mule-unix) + (nth 5 (file-attributes relfile)))) + (insert ";;; Generated autoloads from " relfile "\n"))) + (insert generate-autoload-section-trailer)))) + (or noninteractive + (message "Generating autoloads for %s...done" file))) + (or visited + ;; We created this buffer, so we should kill it. + (kill-buffer (current-buffer)))) + (or (not output-start) + ;; If the entries were added to some other buffer, then the file + ;; doesn't add entries to OUTFILE. + otherbuf)) + (nth 5 (file-attributes absfile)))) + (error + ;; Probably unbalanced parens in forward-sexp. In that case, the + ;; condition is scan-error, and the signal data includes point + ;; where the error was found; we'd like to convert that to + ;; line:col, but line-number-at-pos gets the wrong line in batch + ;; mode for some reason. + ;; + ;; At least this gets the file name in the error message; the + ;; developer can use goto-char to get to the error position. + (error "%s:0:0: error: %s: %s" file (car err) (cdr err))) + )) (defun autoload-save-buffers () (while autoload-modified-buffers @@ -737,7 +773,7 @@ write its autoloads into the specified file instead." t files-re)) dirs))) (done ()) - (this-time (current-time)) + (last-time) ;; Files with no autoload cookies or whose autoloads go to other ;; files because of file-local autoload-generated-file settings. (no-autoloads nil) @@ -762,14 +798,14 @@ write its autoloads into the specified file instead." ;; There shouldn't be more than one such entry. ;; Remove the obsolete section. (autoload-remove-section (match-beginning 0)) - (let ((last-time (nth 4 form))) - (dolist (file file) - (let ((file-time (nth 5 (file-attributes file)))) - (when (and file-time - (not (time-less-p last-time file-time))) - ;; file unchanged - (push file no-autoloads) - (setq files (delete file files))))))) + (setq last-time (nth 4 form)) + (dolist (file file) + (let ((file-time (nth 5 (file-attributes file)))) + (when (and file-time + (not (time-less-p last-time file-time))) + ;; file unchanged + (push file no-autoloads) + (setq files (delete file files)))))) ((not (stringp file))) ((or (not (file-exists-p file)) ;; Remove duplicates as well, just in case. @@ -791,24 +827,28 @@ write its autoloads into the specified file instead." (push file done) (setq files (delete file files))))) ;; Elements remaining in FILES have no existing autoload sections yet. - (dolist (file files) - (cond - ((member (expand-file-name file) autoload-excludes) nil) - ;; Passing nil as second argument forces - ;; autoload-generate-file-autoloads to look for the right - ;; spot where to insert each autoloads section. - ((autoload-generate-file-autoloads file nil buffer-file-name) - (push file no-autoloads)))) - - (when no-autoloads - ;; Sort them for better readability. - (setq no-autoloads (sort no-autoloads 'string<)) - ;; Add the `no-autoloads' section. - (goto-char (point-max)) - (search-backward "\f" nil t) - (autoload-insert-section-header - (current-buffer) nil nil no-autoloads this-time) - (insert generate-autoload-section-trailer)) + (let ((no-autoloads-time (or last-time '(0 0 0 0))) file-time) + (dolist (file files) + (cond + ((member (expand-file-name file) autoload-excludes) nil) + ;; Passing nil as second argument forces + ;; autoload-generate-file-autoloads to look for the right + ;; spot where to insert each autoloads section. + ((setq file-time + (autoload-generate-file-autoloads file nil buffer-file-name)) + (push file no-autoloads) + (if (time-less-p no-autoloads-time file-time) + (setq no-autoloads-time file-time))))) + + (when no-autoloads + ;; Sort them for better readability. + (setq no-autoloads (sort no-autoloads 'string<)) + ;; Add the `no-autoloads' section. + (goto-char (point-max)) + (search-backward "\f" nil t) + (autoload-insert-section-header + (current-buffer) nil nil no-autoloads no-autoloads-time) + (insert generate-autoload-section-trailer))) (let ((version-control 'never)) (save-buffer)) diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 4481bc9ae61..99a329b021e 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 +;;; avl-tree.el --- balanced binary trees, AVL-trees -*- lexical-binding:t -*- -;; Copyright (C) 1995, 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2007-2015 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 @@ -27,23 +27,23 @@ ;;; Commentary: -;; An AVL tree is a self-balancing binary tree. As such, inserting, +;; An AVL tree is a self-balancing binary tree. As such, inserting, ;; deleting, and retrieving data from an AVL tree containing n elements -;; is O(log n). It is somewhat more rigidly balanced than other +;; is O(log n). It is somewhat more rigidly balanced than other ;; self-balancing binary trees (such as red-black trees and AA trees), ;; making insertion slightly slower, deletion somewhat slower, and ;; retrieval somewhat faster (the asymptotic scaling is of course the -;; same for all types). Thus it may be a good choice when the tree will +;; same for all types). Thus it may be a good choice when the tree will ;; be relatively static, i.e. data will be retrieved more often than ;; they are modified. ;; ;; Internally, a tree consists of two elements, the root node and the -;; comparison function. The actual tree has a dummy node as its root +;; comparison function. The actual tree has a dummy node as its root ;; with the real root in the left pointer, which allows the root node to ;; be treated on a par with all other nodes. ;; ;; Each node of the tree consists of one data element, one left -;; sub-tree, one right sub-tree, and a balance count. The latter is the +;; sub-tree, one right sub-tree, and a balance count. The latter is the ;; difference in depth of the left and right sub-trees. ;; ;; The functions with names of the form "avl-tree--" are intended for @@ -51,7 +51,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) @@ -62,7 +62,7 @@ ;; ---------------------------------------------------------------- ;; Functions and macros handling an AVL tree. -(defstruct (avl-tree- +(cl-defstruct (avl-tree- ;; A tagged list is the pre-defstruct representation. ;; (:type list) :named @@ -77,15 +77,10 @@ ;; Return the root node for an AVL tree. INTERNAL USE ONLY. `(avl-tree--node-left (avl-tree--dummyroot ,tree))) -(defsetf avl-tree--root (tree) (node) - `(setf (avl-tree--node-left (avl-tree--dummyroot ,tree)) ,node)) - - - ;; ---------------------------------------------------------------- ;; Functions and macros handling an AVL tree node. -(defstruct (avl-tree--node +(cl-defstruct (avl-tree--node ;; We force a representation without tag so it matches the ;; pre-defstruct representation. Also we use the underlying ;; representation in the implementation of @@ -97,7 +92,7 @@ left right data balance) -(defalias 'avl-tree--node-branch 'aref +(defalias 'avl-tree--node-branch #'aref ;; This implementation is efficient but breaks the defstruct ;; abstraction. An alternative could be (funcall (aref [avl-tree-left ;; avl-tree-right avl-tree-data] branch) node) @@ -109,7 +104,7 @@ NODE is the node, and BRANCH is the branch. ;; The funcall/aref trick wouldn't work for the setf method, unless we ;; tried to access the underlying setter function, but this wouldn't be ;; portable either. -(defsetf avl-tree--node-branch aset) +(gv-define-simple-setter avl-tree--node-branch aset) @@ -297,7 +292,8 @@ Return t if the height of the tree has grown." (if (< (* sgn b2) 0) sgn 0) (avl-tree--node-branch node branch) p2)) (setf (avl-tree--node-balance - (avl-tree--node-branch node branch)) 0) + (avl-tree--node-branch node branch)) + 0) nil)))) (defun avl-tree--do-enter (cmpfun root branch data &optional updatefun) @@ -346,7 +342,7 @@ inserted data." (if (null node) 0 (let ((dl (avl-tree--check-node (avl-tree--node-left node))) (dr (avl-tree--check-node (avl-tree--node-right node)))) - (assert (= (- dr dl) (avl-tree--node-balance node))) + (cl-assert (= (- dr dl) (avl-tree--node-balance node))) (1+ (max dl dr))))) ;; ---------------------------------------------------------------- @@ -391,7 +387,7 @@ itself." (avl-tree--node-data root) (avl-tree--node-balance root)))) -(defstruct (avl-tree--stack +(cl-defstruct (avl-tree--stack (:constructor nil) (:constructor avl-tree--stack-create (tree &optional reverse @@ -403,7 +399,7 @@ itself." (:copier nil)) reverse store) -(defalias 'avl-tree-stack-p 'avl-tree--stack-p +(defalias 'avl-tree-stack-p #'avl-tree--stack-p "Return t if argument is an avl-tree-stack, nil otherwise.") (defun avl-tree--stack-repopulate (stack) @@ -420,12 +416,12 @@ itself." ;;; The public functions which operate on AVL trees. ;; define public alias for constructors so that we can set docstring -(defalias 'avl-tree-create 'avl-tree--create +(defalias 'avl-tree-create #'avl-tree--create "Create an empty AVL tree. COMPARE-FUNCTION is a function which takes two arguments, A and B, and returns non-nil if A is less than B, and nil otherwise.") -(defalias 'avl-tree-compare-function 'avl-tree--cmpfun +(defalias 'avl-tree-compare-function #'avl-tree--cmpfun "Return the comparison function for the AVL tree TREE. \(fn TREE)") @@ -505,7 +501,7 @@ previously specified in `avl-tree-create' when TREE was created." (not (eq (avl-tree-member tree data flag) flag)))) -(defun avl-tree-map (__map-function__ tree &optional reverse) +(defun avl-tree-map (fun tree &optional reverse) "Modify all elements in the AVL tree TREE by applying FUNCTION. Each element is replaced by the return value of FUNCTION applied @@ -516,12 +512,12 @@ descending order if REVERSE is non-nil." (avl-tree--mapc (lambda (node) (setf (avl-tree--node-data node) - (funcall __map-function__ (avl-tree--node-data node)))) + (funcall fun (avl-tree--node-data node)))) (avl-tree--root tree) (if reverse 1 0))) -(defun avl-tree-mapc (__map-function__ tree &optional reverse) +(defun avl-tree-mapc (fun tree &optional reverse) "Apply FUNCTION to all elements in AVL tree TREE, for side-effect only. @@ -529,13 +525,13 @@ FUNCTION is applied to the elements in ascending order, or descending order if REVERSE is non-nil." (avl-tree--mapc (lambda (node) - (funcall __map-function__ (avl-tree--node-data node))) + (funcall fun (avl-tree--node-data node))) (avl-tree--root tree) (if reverse 1 0))) (defun avl-tree-mapf - (__map-function__ combinator tree &optional reverse) + (fun combinator tree &optional reverse) "Apply FUNCTION to all elements in AVL tree TREE, and combine the results using COMBINATOR. @@ -546,7 +542,7 @@ order, or descending order if REVERSE is non-nil." (lambda (node) (setq avl-tree-mapf--accumulate (funcall combinator - (funcall __map-function__ + (funcall fun (avl-tree--node-data node)) avl-tree-mapf--accumulate))) (avl-tree--root tree) @@ -554,7 +550,7 @@ order, or descending order if REVERSE is non-nil." (nreverse avl-tree-mapf--accumulate))) -(defun avl-tree-mapcar (__map-function__ tree &optional reverse) +(defun avl-tree-mapcar (fun tree &optional reverse) "Apply FUNCTION to all elements in AVL tree TREE, and make a list of the results. @@ -568,7 +564,7 @@ then (avl-tree-mapf function 'cons tree (not reverse)) is more efficient." - (nreverse (avl-tree-mapf __map-function__ 'cons tree reverse))) + (nreverse (avl-tree-mapf fun 'cons tree reverse))) (defun avl-tree-first (tree) @@ -605,7 +601,7 @@ is more efficient." "Return the number of elements in TREE." (let ((treesize 0)) (avl-tree--mapc - (lambda (data) (setq treesize (1+ treesize))) + (lambda (_) (setq treesize (1+ treesize))) (avl-tree--root tree) 0) treesize)) @@ -619,7 +615,7 @@ is more efficient." of all elements of TREE. If REVERSE is non-nil, the stack is sorted in reverse order. -\(See also `avl-tree-stack-pop'\). +\(See also `avl-tree-stack-pop'). Note that any modification to TREE *immediately* invalidates all avl-tree-stacks created before the modification (in particular, diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index 2dc84e9ddfb..dc61e156130 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-2015 Free Software Foundation, ;; Inc. ;; Author: Rick Sladkey <jrs@world.std.com> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: extensions, internal ;; Package: emacs @@ -99,9 +99,9 @@ places where expressions are evaluated and inserted or spliced in. For example: b => (ba bb bc) ; assume b has this value -`(a b c) => (a b c) ; backquote acts like quote -`(a ,b c) => (a (ba bb bc) c) ; insert the value of b -`(a ,@b c) => (a ba bb bc c) ; splice in the value of b +\\=`(a b c) => (a b c) ; backquote acts like quote +\\=`(a ,b c) => (a (ba bb bc) c) ; insert the value of b +\\=`(a ,@b c) => (a ba bb bc c) ; splice in the value of b Vectors work just like lists. Nested backquotes are permitted." (cdr (backquote-process structure))) @@ -120,9 +120,7 @@ Vectors work just like lists. Nested backquotes are permitted." This simply recurses through the body." (let ((exp (backquote-listify (list (cons 0 (list 'quote (car s)))) (backquote-process (cdr s) level)))) - (if (eq (car-safe exp) 'quote) - (cons 0 (list 'quote s)) - (cons 1 exp)))) + (cons (if (eq (car-safe exp) 'quote) 0 1) exp))) (defun backquote-process (s &optional level) "Process the body of a backquote. @@ -148,16 +146,26 @@ LEVEL is only used internally and indicates the nesting level: (t (list 'apply '(function vector) (cdr n)))))))) ((atom s) + ;; FIXME: Use macroexp-quote! (cons 0 (if (or (null s) (eq s t) (not (symbolp s))) s (list 'quote s)))) ((eq (car s) backquote-unquote-symbol) (if (<= level 0) - (cons 1 (nth 1 s)) + (cond + ((> (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)) + (t (cons (if (eq (car-safe (nth 1 s)) 'quote) 0 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))) @@ -208,9 +216,7 @@ LEVEL is only used internally and indicates the nesting level: ;; Tack on any initial elements. (if firstlist (setq expression (backquote-listify firstlist (cons 1 expression)))) - (if (eq (car-safe expression) 'quote) - (cons 0 (list 'quote s)) - (cons 1 expression)))))) + (cons (if (eq (car-safe expression) 'quote) 0 1) expression))))) ;; backquote-listify takes (tag . structure) pairs from backquote-process ;; and decides between append, list, backquote-list*, and cons depending diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index c97b33f4e7d..dc1b44e3164 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-2015 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..2aa636e4e82 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-2015 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 7214501362d..c3c61d6c81e 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-2015 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 @@ -192,7 +192,7 @@ ;; (if (aref byte-code-vector 0) ;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) (byte-compile-log-1 - (apply 'format format + (apply #'format-message format (let (c a) (mapcar (lambda (arg) (if (not (consp arg)) @@ -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 @@ -292,7 +292,7 @@ (format "Inlining closure %S failed" name)) form)))) - (t ;; Give up on inlining. + (_ ;; Give up on inlining. form)))) ;; ((lambda ...) ...) @@ -302,65 +302,65 @@ ;; doesn't matter here, because function's behavior is underspecified so it ;; can safely be turned into a `let', even though the reverse is not true. (or name (setq name "anonymous lambda")) - (let ((lambda (car form)) - (values (cdr form))) - (let ((arglist (nth 1 lambda)) - (body (cdr (cdr lambda))) - optionalp restp - bindings) - (if (and (stringp (car body)) (cdr body)) - (setq body (cdr body))) - (if (and (consp (car body)) (eq 'interactive (car (car body)))) - (setq body (cdr body))) - ;; FIXME: The checks below do not belong in an optimization phase. - (while arglist - (cond ((eq (car arglist) '&optional) - ;; ok, I'll let this slide because funcall_lambda() does... - ;; (if optionalp (error "multiple &optional keywords in %s" name)) - (if restp (error "&optional found after &rest in %s" name)) - (if (null (cdr arglist)) - (error "nothing after &optional in %s" name)) - (setq optionalp t)) - ((eq (car arglist) '&rest) - ;; ...but it is by no stretch of the imagination a reasonable - ;; thing that funcall_lambda() allows (&rest x y) and - ;; (&rest x &optional y) in arglists. - (if (null (cdr arglist)) - (error "nothing after &rest in %s" name)) - (if (cdr (cdr arglist)) - (error "multiple vars after &rest in %s" name)) - (setq restp t)) - (restp - (setq bindings (cons (list (car arglist) - (and values (cons 'list values))) - bindings) - values nil)) - ((and (not optionalp) (null values)) - (byte-compile-warn "attempt to open-code `%s' with too few arguments" name) - (setq arglist nil values 'too-few)) - (t - (setq bindings (cons (list (car arglist) (car values)) - bindings) - values (cdr values)))) - (setq arglist (cdr arglist))) - (if values - (progn - (or (eq values 'too-few) - (byte-compile-warn - "attempt to open-code `%s' with too many arguments" name)) - form) - - ;; The following leads to infinite recursion when loading a - ;; file containing `(defsubst f () (f))', and then trying to - ;; byte-compile that file. - ;(setq body (mapcar 'byte-optimize-form body))) - - (let ((newform - (if bindings - (cons 'let (cons (nreverse bindings) body)) - (cons 'progn body)))) - (byte-compile-log " %s\t==>\t%s" form newform) - newform))))) + (let* ((lambda (car form)) + (values (cdr form)) + (arglist (nth 1 lambda)) + (body (cdr (cdr lambda))) + optionalp restp + bindings) + (if (and (stringp (car body)) (cdr body)) + (setq body (cdr body))) + (if (and (consp (car body)) (eq 'interactive (car (car body)))) + (setq body (cdr body))) + ;; FIXME: The checks below do not belong in an optimization phase. + (while arglist + (cond ((eq (car arglist) '&optional) + ;; ok, I'll let this slide because funcall_lambda() does... + ;; (if optionalp (error "multiple &optional keywords in %s" name)) + (if restp (error "&optional found after &rest in %s" name)) + (if (null (cdr arglist)) + (error "nothing after &optional in %s" name)) + (setq optionalp t)) + ((eq (car arglist) '&rest) + ;; ...but it is by no stretch of the imagination a reasonable + ;; thing that funcall_lambda() allows (&rest x y) and + ;; (&rest x &optional y) in arglists. + (if (null (cdr arglist)) + (error "nothing after &rest in %s" name)) + (if (cdr (cdr arglist)) + (error "multiple vars after &rest in %s" name)) + (setq restp t)) + (restp + (setq bindings (cons (list (car arglist) + (and values (cons 'list values))) + bindings) + values nil)) + ((and (not optionalp) (null values)) + (byte-compile-warn "attempt to open-code `%s' with too few arguments" name) + (setq arglist nil values 'too-few)) + (t + (setq bindings (cons (list (car arglist) (car values)) + bindings) + values (cdr values)))) + (setq arglist (cdr arglist))) + (if values + (progn + (or (eq values 'too-few) + (byte-compile-warn + "attempt to open-code `%s' with too many arguments" name)) + form) + + ;; The following leads to infinite recursion when loading a + ;; file containing `(defsubst f () (f))', and then trying to + ;; byte-compile that file. + ;(setq body (mapcar 'byte-optimize-form body))) + + (let ((newform + (if bindings + (cons 'let (cons (nreverse bindings) body)) + (cons 'progn body)))) + (byte-compile-log " %s\t==>\t%s" form newform) + newform)))) ;;; implementing source-level optimizers @@ -390,12 +390,13 @@ (and (nth 1 form) (not for-effect) form)) - ((eq 'lambda (car-safe fn)) + ((eq (car-safe fn) 'lambda) (let ((newform (byte-compile-unfold-lambda form))) (if (eq newform form) ;; Some error occurred, avoid infinite recursion form (byte-optimize-form-code-walker newform for-effect)))) + ((eq (car-safe fn) 'closure) form) ((memq fn '(let let*)) ;; recursively enter the optimizer for the bindings and body ;; of a let or let*. This for depth-firstness: forms that @@ -488,11 +489,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 @@ -504,13 +516,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 @@ -533,18 +546,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)) @@ -565,7 +566,7 @@ (cons fn args))))))) (defun byte-optimize-all-constp (list) - "Non-nil if all elements of LIST satisfy `macroexp-const-p" + "Non-nil if all elements of LIST satisfy `macroexp-const-p'." (let ((constant t)) (while (and list constant) (unless (macroexp-const-p (car list)) @@ -859,14 +860,16 @@ (defun byte-optimize-binary-predicate (form) - (if (macroexp-const-p (nth 1 form)) - (if (macroexp-const-p (nth 2 form)) - (condition-case () - (list 'quote (eval form)) - (error form)) - ;; This can enable some lapcode optimizations. - (list (car form) (nth 2 form) (nth 1 form))) - form)) + (cond + ((or (not (macroexp-const-p (nth 1 form))) + (nthcdr 3 form)) ;; In case there are more than 2 args. + form) + ((macroexp-const-p (nth 2 form)) + (condition-case () + (list 'quote (eval form)) + (error form))) + (t ;; This can enable some lapcode optimizations. + (list (car form) (nth 2 form) (nth 1 form))))) (defun byte-optimize-predicate (form) (let ((ok t) @@ -942,15 +945,6 @@ form (nth 1 form))) -(defun byte-optimize-zerop (form) - (cond ((numberp (nth 1 form)) - (eval form)) - (byte-compile-delete-errors - (list '= (nth 1 form) 0)) - (form))) - -(put 'zerop 'byte-optimizer 'byte-optimize-zerop) - (defun byte-optimize-and (form) ;; Simplify if less than 2 args. ;; if there is a literal nil in the args to `and', throw it and following @@ -1231,7 +1225,7 @@ window-left-child window-left-column window-margins window-minibuffer-p window-next-buffers window-next-sibling window-new-normal window-new-total window-normal-size window-parameter window-parameters - window-parent window-pixel-edges window-point window-prev-buffers + window-parent window-pixel-edges window-point window-prev-buffers window-prev-sibling window-redisplay-end-trigger window-scroll-bars window-start window-text-height window-top-child window-top-line window-total-height window-total-width window-use-time window-vscroll @@ -1304,7 +1298,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) @@ -1323,7 +1317,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 0bb04950dfd..73c2977e8eb 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-2015 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 @@ -30,6 +30,18 @@ ;;; Code: +(defalias 'function-put + ;; We don't want people to just use `put' because we can't conveniently + ;; hook into `put' to remap old properties to new ones. But for now, there's + ;; no such remapping, so we just call `put'. + #'(lambda (function prop value) + "Set FUNCTION's property PROP to VALUE. +The namespace for PROP is shared with symbols. +So far, FUNCTION can only be a symbol, not a lambda expression." + (put function prop value))) +(function-put 'defmacro 'doc-string-elt 3) +(function-put 'defmacro 'lisp-indent-function 2) + ;; `macro-declaration-function' are both obsolete (as marked at the end of this ;; file) but used in many .elc files. @@ -69,6 +81,7 @@ The return value of this function is not used." ;; handle declarations in macro definitions and this is the first file ;; loaded by loadup.el that uses declarations in macros. +;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist (list ;; We can only use backquotes inside the lambdas and not for those @@ -81,43 +94,77 @@ The return value of this function is not used." #'(lambda (f _args new-name when) (list 'make-obsolete (list 'quote f) (list 'quote new-name) (list 'quote when)))) + (list 'interactive-only + #'(lambda (f _args instead) + (list 'function-put (list 'quote f) + ''interactive-only (list 'quote instead)))) + ;; FIXME: Merge `pure' and `side-effect-free'. + (list 'pure + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''pure (list 'quote val))) + "If non-nil, the compiler can replace calls with their return value. +This may shift errors from run-time to compile-time.") + (list 'side-effect-free + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''side-effect-free (list 'quote val))) + "If non-nil, calls can be ignored if their value is unused. +If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") (list 'compiler-macro #'(lambda (f args compiler-function) - `(eval-and-compile - (put ',f 'compiler-macro - ,(if (eq (car-safe compiler-function) 'lambda) - `(lambda ,(append (cadr compiler-function) args) - ,@(cddr compiler-function)) - `#',compiler-function))))) + (if (not (eq (car-safe compiler-function) 'lambda)) + `(eval-and-compile + (function-put ',f 'compiler-macro #',compiler-function)) + (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro")))) + `(progn + (eval-and-compile + (function-put ',f 'compiler-macro #',cfname)) + ;; Don't autoload the compiler-macro itself, since the + ;; macroexpander will find this file via `f's autoload, + ;; if needed. + :autoload-end + (eval-and-compile + (defun ,cfname (,@(cadr compiler-function) ,@args) + ,@(cddr compiler-function)))))))) (list 'doc-string #'(lambda (f _args pos) - (list 'put (list 'quote f) ''doc-string-elt (list 'quote pos)))) + (list 'function-put (list 'quote f) + ''doc-string-elt (list 'quote pos)))) (list 'indent #'(lambda (f _args val) - (list 'put (list 'quote f) + (list 'function-put (list 'quote f) ''lisp-indent-function (list 'quote val))))) "List associating function properties to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. For each (PROP . VALUES) in a function's declaration, the FUN corresponding to PROP is called with the function name, the function's arglist, and the VALUES and should return the code to use -to set this property.") +to set this property. + +This is used by `declare'.") (defvar macro-declarations-alist (cons (list 'debug - #'(lambda (name _args spec) - (list 'progn :autoload-end - (list 'put (list 'quote name) - ''edebug-form-spec (list 'quote spec))))) - defun-declarations-alist) + #'(lambda (name _args spec) + (list 'progn :autoload-end + (list 'put (list 'quote name) + ''edebug-form-spec (list 'quote spec))))) + (cons + (list 'no-font-lock-keyword + #'(lambda (name _args val) + (list 'function-put (list 'quote name) + ''no-font-lock-keyword (list 'quote val)))) + 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. + +This is used by `declare'.") -(put 'defmacro 'doc-string-elt 3) (defalias 'defmacro (cons 'macro @@ -159,6 +206,19 @@ The return value is undefined. (message "Warning: Unknown macro property %S in %S" (car x) name)))) decls))) + ;; Refresh font-lock if this is a new macro, or it is an + ;; existing macro whose 'no-font-lock-keyword declaration + ;; has changed. + (if (and + ;; If lisp-mode hasn't been loaded, there's no reason + ;; to flush. + (fboundp 'lisp--el-font-lock-flush-elisp-buffers) + (or (not (fboundp name)) ;; new macro + (and (fboundp name) ;; existing macro + (member `(function-put ',name 'no-font-lock-keyword + ',(get name 'no-font-lock-keyword)) + declarations)))) + (lisp--el-font-lock-flush-elisp-buffers)) (if declarations (cons 'prog1 (cons def declarations)) def)))))) @@ -179,7 +239,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))) @@ -217,7 +277,8 @@ The return value is undefined. (cons arglist body)))))) (if declarations (cons 'prog1 (cons def declarations)) - def)))) + def)))) + ;; Redefined in byte-optimize.el. ;; This is not documented--it's not clear that we should promote it. @@ -284,7 +345,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. @@ -295,12 +355,12 @@ was first made obsolete, for example a date or a release number." &optional when docstring) "Set OBSOLETE-NAME's function definition to CURRENT-NAME and mark it obsolete. -\(define-obsolete-function-alias 'old-fun 'new-fun \"22.1\" \"old-fun's doc.\") +\(define-obsolete-function-alias \\='old-fun \\='new-fun \"22.1\" \"old-fun's doc.\") is equivalent to the following two lines of code: -\(defalias 'old-fun 'new-fun \"old-fun's doc.\") -\(make-obsolete 'old-fun 'new-fun \"22.1\") +\(defalias \\='old-fun \\='new-fun \"old-fun's doc.\") +\(make-obsolete \\='old-fun \\='new-fun \"22.1\") See the docstrings of `defalias' and `make-obsolete' for more details." (declare (doc-string 4) @@ -333,7 +393,7 @@ ACCESS-TYPE if non-nil should specify the kind of access that will trigger This uses `defvaralias' and `make-obsolete-variable' (which see). See the Info node `(elisp)Variable Aliases' for more details. -If CURRENT-NAME is a defcustom (more generally, any variable +If CURRENT-NAME is a defcustom or a defvar (more generally, any variable where OBSOLETE-NAME may be set, e.g. in an init file, before the alias is defined), then the define-obsolete-variable-alias statement should be evaluated before the defcustom, if user @@ -347,7 +407,7 @@ variable (this is due to the way `defvaralias' works). For the benefit of `custom-set-variables', if OBSOLETE-NAME has any of the following properties, they are copied to CURRENT-NAME, if it does not already have them: -'saved-value, 'saved-variable-comment." +`saved-value', `saved-variable-comment'." (declare (doc-string 4) (advertised-calling-convention ;; New code should always provide the `when' argument. @@ -389,13 +449,20 @@ If you think you need this, you're probably making a mistake somewhere." (defmacro eval-when-compile (&rest body) "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)) +Thus, the result of the body appears to the compiler as a quoted +constant. In interpreted code, this is entirely equivalent to +`progn', except that the value of the expression may be (but is +not necessarily) computed at load time if eager macro expansion +is enabled." + (declare (debug (&rest def-form)) (indent 0)) (list 'quote (eval (cons 'progn body) lexical-binding))) (defmacro eval-and-compile (&rest body) - "Like `progn', but evaluates the body at compile time and at load time." + "Like `progn', but evaluates the body at compile time and at +load time. In interpreted code, this is entirely equivalent to +`progn', except that the value of the expression may be (but is +not necessarily) computed at load time if eager macro expansion +is enabled." (declare (debug t) (indent 0)) ;; When the byte-compiler expands code, this macro is not used, so we're ;; either about to run `body' (plain interpretation) or we're doing eager diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c6612024fa6..db200f3c504 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-2015 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 @@ -31,6 +31,10 @@ ;; faster. [`LAP' == `Lisp Assembly Program'.] ;; The user entry points are byte-compile-file and byte-recompile-directory. +;;; Todo: + +;; - Turn "not bound at runtime" functions into autoloads. + ;;; Code: ;; ======================================================================== @@ -120,7 +124,11 @@ (require 'backquote) (require 'macroexp) (require 'cconv) -(eval-when-compile (require 'cl-lib)) + +;; During bootstrap, cl-loaddefs.el is not created yet, so loading cl-lib +;; doesn't setup autoloads for things like cl-every, which is why we have to +;; require cl-extra instead (bug#18804). +(require 'cl-extra) (or (fboundp 'defsubst) ;; This really ought to be loaded already! @@ -340,7 +348,7 @@ else the global value will be modified." ;;;###autoload (defun byte-compile-enable-warning (warning) "Change `byte-compile-warnings' to enable WARNING. -If `byte-compile-warnings' is `t', do nothing. Otherwise, if the +If `byte-compile-warnings' is t, do nothing. Otherwise, if the first element is `not', remove WARNING, else add it. Normally you should let-bind `byte-compile-warnings' before calling this, else the global value will be modified." @@ -353,11 +361,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.") @@ -389,7 +397,7 @@ invoked interactively are excluded from this list." "Alist of functions and their call tree. Each element looks like - \(FUNCTION CALLERS CALLS\) + (FUNCTION CALLERS CALLS) where CALLERS is a list of functions that call FUNCTION, and CALLS is a list of functions for which calls were generated while compiling @@ -413,7 +421,7 @@ specify different fields to sort on." 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.") +Filled in `cconv-analyze-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) @@ -421,31 +429,51 @@ Filled in `cconv-analyse-form' but initialized and consulted here.") (defvar byte-compiler-error-flag) +(defun byte-compile-recurse-toplevel (form non-toplevel-case) + "Implement `eval-when-compile' and `eval-and-compile'. +Return the compile-time value of FORM." + ;; Macroexpand (not macroexpand-all!) form at toplevel in case it + ;; expands into a toplevel-equivalent `progn'. See CLHS section + ;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very + ;; subtle: see test/automated/bytecomp-tests.el for interesting + ;; cases. + (setf form (macroexp-macroexpand form byte-compile-macro-environment)) + (if (eq (car-safe form) 'progn) + (cons 'progn + (mapcar (lambda (subform) + (byte-compile-recurse-toplevel + subform non-toplevel-case)) + (cdr form))) + (funcall non-toplevel-case form))) + (defconst byte-compile-initial-macro-environment - '( + `( ;; (byte-compiler-options . (lambda (&rest forms) ;; (apply 'byte-compiler-options-handler forms))) (declare-function . byte-compile-macroexpand-declare-function) - (eval-when-compile . (lambda (&rest body) - (list - 'quote - (byte-compile-eval - (byte-compile-top-level - (byte-compile-preprocess (cons 'progn body))))))) - (eval-and-compile . (lambda (&rest body) - ;; Byte compile before running it. Do it piece by - ;; piece, in case further expressions need earlier - ;; ones to be evaluated already, as is the case in - ;; eieio.el. - `(progn - ,@(mapcar (lambda (exp) - (let ((cexp - (byte-compile-top-level - (byte-compile-preprocess - exp)))) - (eval cexp) - cexp)) - body))))) + (eval-when-compile . ,(lambda (&rest body) + (let ((result nil)) + (byte-compile-recurse-toplevel + (macroexp-progn body) + (lambda (form) + (setf result + (byte-compile-eval + (byte-compile-top-level + (byte-compile-preprocess form)))))) + (list 'quote result)))) + (eval-and-compile . ,(lambda (&rest body) + (byte-compile-recurse-toplevel + (macroexp-progn body) + (lambda (form) + ;; Don't compile here, since we don't know + ;; whether to compile as byte-compile-form + ;; or byte-compile-file-form. + (let ((expanded + (macroexpand-all + form + macroexpand-all-environment))) + (eval expanded lexical-binding) + expanded)))))) "The default macro-environment passed to macroexpand by the compiler. Placing a macro here will cause a macro to have different semantics when expanded by the compiler as when expanded by the interpreter.") @@ -535,7 +563,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) @@ -707,7 +741,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)) @@ -938,7 +973,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (print-level 4) (print-length 4)) (byte-compile-log-1 - (format + (format-message ,format-string ,@(mapcar (lambda (x) (if (symbolp x) (list 'prin1-to-string x) x)) @@ -1085,7 +1120,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." pt) (when dir (unless was-same - (insert (format "Leaving directory `%s'\n" default-directory)))) + (insert (format-message "Leaving directory `%s'\n" + default-directory)))) (unless (bolp) (insert "\n")) (setq pt (point-marker)) @@ -1100,8 +1136,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (when dir (setq default-directory dir) (unless was-same - (insert (format "Entering directory `%s'\n" - default-directory)))) + (insert (format-message "Entering directory `%s'\n" + default-directory)))) (setq byte-compile-last-logged-file byte-compile-current-file byte-compile-last-warned-form nil) ;; Do this after setting default-directory. @@ -1119,7 +1155,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defun byte-compile-warn (format &rest args) "Issue a byte compiler warning; use (format FORMAT ARGS...) for message." - (setq format (apply 'format format args)) + (setq format (apply #'format-message format args)) (if byte-compile-error-on-warn (error "%s" format) ; byte-compile-file catches and logs it (byte-compile-log-warning format t :warning))) @@ -1136,10 +1172,13 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (byte-compile-warn "%s" msg))))) (defun byte-compile-report-error (error-info) - "Report Lisp error in compilation. ERROR-INFO is the error data." + "Report Lisp error in compilation. +ERROR-INFO is the error data, in the form of either (ERROR-SYMBOL . DATA) +or STRING." (setq byte-compiler-error-flag t) (byte-compile-log-warning - (error-message-string error-info) + (if (stringp error-info) error-info + (error-message-string error-info)) nil :error)) ;;; sanity-checking arglists @@ -1258,8 +1297,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. @@ -1316,13 +1354,13 @@ extra args." (let ((keyword-args (cdr (cdr (cdr (cdr form))))) (name (cadr form))) (or (not (eq (car-safe name) 'quote)) - (and (eq (car form) 'custom-declare-group) - (equal name ''emacs)) - (plist-get keyword-args :group) - (not (and (consp name) (eq (car name) 'quote))) - (byte-compile-warn - "%s for `%s' fails to specify containing group" - (cdr (assq (car form) + (and (eq (car form) 'custom-declare-group) + (equal name ''emacs)) + (plist-get keyword-args :group) + (not (and (consp name) (eq (car name) 'quote))) + (byte-compile-warn + "%s for `%s' fails to specify containing group" + (cdr (assq (car form) '((custom-declare-group . defgroup) (custom-declare-face . defface) (custom-declare-variable . defcustom)))) @@ -1336,6 +1374,33 @@ extra args." ;; Warn if the function or macro is being redefined with a different ;; number of arguments. (defun byte-compile-arglist-warn (name arglist macrop) + ;; This is the first definition. See if previous calls are compatible. + (let ((calls (assq name byte-compile-unresolved-functions)) + nums sig min max) + (when (and calls macrop) + (byte-compile-warn "macro `%s' defined too late" name)) + (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)) + (byte-compile-warn "defsubst `%s' was used before it was defined" + name)) + (setq sig (byte-compile-arglist-signature arglist) + nums (sort (copy-sequence (cdr calls)) (function <)) + min (car nums) + max (car (nreverse nums))) + (when (or (< min (car sig)) + (and (cdr sig) (> max (cdr sig)))) + (byte-compile-set-symbol-position name) + (byte-compile-warn + "%s being defined to take %s%s, but was previously called with %s" + name + (byte-compile-arglist-signature-string sig) + (if (equal sig '(1 . 1)) " arg" " args") + (byte-compile-arglist-signature-string (cons min max)))))) (let* ((old (byte-compile-fdefinition name macrop)) (initial (and macrop (cdr (assq name @@ -1344,52 +1409,26 @@ extra args." ;; to a defined function. (Bug#8646) (and initial (symbolp initial) (setq old (byte-compile-fdefinition initial nil))) - (if (and old (not (eq old t))) - (progn - (and (eq 'macro (car-safe old)) - (eq 'lambda (car-safe (cdr-safe old))) - (setq old (cdr old))) - (let ((sig1 (byte-compile-arglist-signature - (pcase old - (`(lambda ,args . ,_) args) - (`(closure ,_ ,args . ,_) args) - ((pred byte-code-function-p) (aref old 0)) - (t '(&rest def))))) - (sig2 (byte-compile-arglist-signature arglist))) - (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) - (byte-compile-set-symbol-position name) - (byte-compile-warn - "%s %s used to take %s %s, now takes %s" - (if macrop "macro" "function") - name - (byte-compile-arglist-signature-string sig1) - (if (equal sig1 '(1 . 1)) "argument" "arguments") - (byte-compile-arglist-signature-string sig2))))) - ;; This is the first definition. See if previous calls are compatible. - (let ((calls (assq name byte-compile-unresolved-functions)) - nums sig min max) - (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)) - (byte-compile-warn "defsubst `%s' was used before it was defined" - name)) - (setq sig (byte-compile-arglist-signature arglist) - nums (sort (copy-sequence (cdr calls)) (function <)) - min (car nums) - max (car (nreverse nums))) - (when (or (< min (car sig)) - (and (cdr sig) (> max (cdr sig)))) - (byte-compile-set-symbol-position name) - (byte-compile-warn - "%s being defined to take %s%s, but was previously called with %s" - name - (byte-compile-arglist-signature-string sig) - (if (equal sig '(1 . 1)) " arg" " args") - (byte-compile-arglist-signature-string (cons min max))))))))) + (when (and old (not (eq old t))) + (and (eq 'macro (car-safe old)) + (eq 'lambda (car-safe (cdr-safe old))) + (setq old (cdr old))) + (let ((sig1 (byte-compile-arglist-signature + (pcase old + (`(lambda ,args . ,_) args) + (`(closure ,_ ,args . ,_) args) + ((pred byte-code-function-p) (aref old 0)) + (_ '(&rest def))))) + (sig2 (byte-compile-arglist-signature arglist))) + (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) + (byte-compile-set-symbol-position name) + (byte-compile-warn + "%s %s used to take %s %s, now takes %s" + (if macrop "macro" "function") + name + (byte-compile-arglist-signature-string sig1) + (if (equal sig1 '(1 . 1)) "argument" "arguments") + (byte-compile-arglist-signature-string sig2))))))) (defvar byte-compile-cl-functions nil "List of functions defined in CL.") @@ -1424,7 +1463,7 @@ extra args." ;; These would sometimes be warned about ;; but such warnings are never useful, ;; so don't warn about them. - macroexpand cl-macroexpand-all + macroexpand cl--compiling-file)))) (byte-compile-warn "function `%s' from cl package called at runtime" func))) @@ -1593,14 +1632,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 @@ -1699,16 +1738,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)) @@ -1763,7 +1800,7 @@ The value is non-nil if there were no errors, nil if errors." (progn (setq-default major-mode 'emacs-lisp-mode) ;; Arg of t means don't alter enable-local-variables. - (normal-mode t)) + (delay-mode-hooks (normal-mode t))) (setq-default major-mode dmm)) ;; There may be a file local variable setting (bug#10419). (setq buffer-read-only nil @@ -1826,13 +1863,13 @@ The value is non-nil if there were no errors, nil if errors." ;; recompiled). Previously this was accomplished by ;; deleting target-file before writing it. (rename-file tempfile target-file t) - (message "Wrote %s" target-file)) + (or noninteractive (message "Wrote %s" target-file))) ;; This is just to give a better error message than write-region (signal 'file-error (list "Opening output file" (if (file-exists-p target-file) - "cannot overwrite file" - "directory not writable or nonexistent") + "Cannot overwrite file" + "Directory not writable or nonexistent") target-file))) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree @@ -1864,7 +1901,10 @@ With argument ARG, insert value in current buffer after the form." (let ((read-with-symbol-positions (current-buffer)) (read-symbol-positions-list nil)) (displaying-byte-compile-warnings - (byte-compile-sexp (read (current-buffer))))) + (byte-compile-sexp + (eval-sexp-add-defvars + (read (current-buffer)) + byte-compile-read-position)))) lexical-binding))) (cond (arg (message "Compiling from buffer... done.") @@ -2092,11 +2132,6 @@ list that represents a doc string reference. (eq (aref (nth (nth 1 info) form) 0) ?*)) (setq position (- position))))) - (if preface - (progn - (insert preface) - (prin1 name byte-compile--outbuffer))) - (insert (car info)) (let ((print-continuous-numbering t) print-number-table (index 0) @@ -2109,6 +2144,15 @@ list that represents a doc string reference. (print-gensym t) (print-circle ; Handle circular data structures. (not byte-compile-disable-print-circle))) + (if preface + (progn + ;; FIXME: We don't handle uninterned names correctly. + ;; E.g. if cl-define-compiler-macro uses uninterned name we get: + ;; (defalias '#1=#:foo--cmacro #[514 ...]) + ;; (put 'foo 'compiler-macro '#:foo--cmacro) + (insert preface) + (prin1 name byte-compile--outbuffer))) + (insert (car info)) (prin1 (car form) byte-compile--outbuffer) (while (setq form (cdr form)) (setq index (1+ index)) @@ -2194,9 +2238,12 @@ list that represents a doc string reference. (t form))) ;; byte-hunk-handlers cannot call this! -(defun byte-compile-toplevel-file-form (form) - (let ((byte-compile-current-form nil)) ; close over this for warnings. - (byte-compile-file-form (byte-compile-preprocess form t)))) +(defun byte-compile-toplevel-file-form (top-level-form) + (byte-compile-recurse-toplevel + top-level-form + (lambda (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. + (byte-compile-file-form (byte-compile-preprocess form t)))))) ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) @@ -2280,10 +2327,12 @@ list that represents a doc string reference. form)) (put 'define-abbrev-table 'byte-hunk-handler - 'byte-compile-file-form-define-abbrev-table) -(defun byte-compile-file-form-define-abbrev-table (form) - (if (eq 'quote (car-safe (car-safe (cdr form)))) - (byte-compile--declare-var (car-safe (cdr (cadr form))))) + 'byte-compile-file-form-defvar-function) +(put 'defvaralias 'byte-hunk-handler 'byte-compile-file-form-defvar-function) + +(defun byte-compile-file-form-defvar-function (form) + (pcase-let (((or `',name (let name nil)) (nth 1 form))) + (if name (byte-compile--declare-var name))) (byte-compile-keep-pending form)) (put 'custom-declare-variable 'byte-hunk-handler @@ -2291,8 +2340,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)) - (byte-compile--declare-var (nth 1 (nth 1 form))) - (byte-compile-keep-pending form)) + (byte-compile-file-form-defvar-function form)) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) @@ -2389,9 +2437,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") @@ -2500,7 +2547,8 @@ If QUOTED is non-nil, print with quoting; otherwise, print without quoting." "Return an expression which will evaluate to a function value FUN. FUN should be either a `lambda' value or a `closure' value." (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil)) - `(closure ,env ,args . ,body)) fun) + `(closure ,env ,args . ,body)) + fun) (renv ())) ;; Turn the function's closed vars (if any) into local let bindings. (dolist (binding env) @@ -2525,7 +2573,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 @@ -2540,18 +2588,14 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (symbolp form) form "provided")) fun) (t - (when (symbolp form) - (unless (memq (car-safe fun) '(closure lambda)) - (error "Don't know how to compile %S" fun)) + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its corresponding + ;; source code. (setq lexical-binding (eq (car fun) 'closure)) (setq fun (byte-compile--reify-function fun))) - (unless (eq (car-safe fun) 'lambda) - (error "Don't know how to compile %S" fun)) ;; Expand macros. (setq fun (byte-compile-preprocess fun)) - ;; Get rid of the `function' quote added by the `lambda' macro. - (if (eq (car-safe fun) 'function) (setq fun (cadr fun))) - (setq fun (byte-compile-lambda fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) (if macro (push 'macro fun)) (if (symbolp form) (fset form fun) @@ -2702,8 +2746,9 @@ for symbols generated by the byte compiler itself." ;; byte-string, constants-vector, stack depth (cdr compiled) ;; optionally, the doc string. - (cond (lexical-binding - (require 'help-fns) + (cond ((and lexical-binding arglist) + ;; byte-compile-make-args-desc lost the args's names, + ;; so preserve them in the docstring. (list (help-add-fundoc-usage doc arglist))) ((or doc int) (list doc))) @@ -2881,11 +2926,17 @@ for symbols generated by the byte compiler itself." ;; Special macro-expander used during byte-compilation. (defun byte-compile-macroexpand-declare-function (fn file &rest args) - (push (cons fn - (if (and (consp args) (listp (car args))) - (list 'declared (car args)) - t)) ; Arglist not specified. - byte-compile-function-environment) + (let ((gotargs (and (consp args) (listp (car args)))) + (unresolved (assq fn byte-compile-unresolved-functions))) + (when unresolved ; function was called before declaration + (if (and gotargs (byte-compile-warning-enabled-p 'callargs)) + (byte-compile-arglist-warn fn (car args) nil) + (setq byte-compile-unresolved-functions + (delq unresolved byte-compile-unresolved-functions)))) + (push (cons fn (if gotargs + (list 'declared (car args)) + t)) ; Arglist not specified. + byte-compile-function-environment)) ;; We are stating that it _will_ be defined at runtime. (setq byte-compile-noruntime-functions (delq fn byte-compile-noruntime-functions)) @@ -2922,17 +2973,39 @@ 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 (memq fn '(set symbol-value run-hooks ;; add-to-list + add-hook remove-hook run-hook-with-args + run-hook-with-args-until-success + run-hook-with-args-until-failure)) + (pcase (cdr form) + (`(',var . ,_) + (when (assq var byte-compile-lexical-variables) + (byte-compile-log-warning + (format-message "%s cannot use lexical var `%s'" fn var) + nil :error))))) (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" + (substitute-command-keys + interactive-only))) + ((and (symbolp 'interactive-only) + (not (eq interactive-only t))) + (format-message "; 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)) + (format "Forgot to expand macro %s in %S" (car form) form) + nil :error)) (if (and handler ;; Make sure that function exists. (and (functionp handler) @@ -3029,8 +3102,9 @@ That command is designed for interactive use only" fn)) (dotimes (_ (- (/ (1+ fmax2) 2) alen)) (byte-compile-push-constant nil))) ((zerop (logand fmax2 1)) - (byte-compile-log-warning "Too many arguments for inlined function" - nil :error) + (byte-compile-log-warning + (format "Too many arguments for inlined function %S" form) + nil :error) (byte-compile-discard (- alen (/ fmax2 2)))) (t ;; Turn &rest args into a list. @@ -3058,7 +3132,7 @@ That command is designed for interactive use only" fn)) (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants) (byte-compile-warn (if (eq access-type 'let-bind) - "attempt to let-bind %s `%s`" + "attempt to let-bind %s `%s'" "variable reference to %s `%s'") (if (symbolp var) "constant" "nonvariable") (prin1-to-string var)))) @@ -3168,6 +3242,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) @@ -3249,11 +3324,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) @@ -3317,6 +3392,18 @@ 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)) + ((cl-every #'macroexp-copyable-p (nthcdr 2 form)) + (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form)) + (,(car form) ,@(nthcdr 2 form))))) + (t (byte-compile-normal-call form))))) + (defun byte-compile-three-args (form) (if (not (= (length form) 4)) (byte-compile-subr-wrong-args form 3) @@ -3390,15 +3477,22 @@ discarding." (if byte-compile--for-effect (setq byte-compile--for-effect nil) (let* ((vars (nth 1 form)) (env (nth 2 form)) - (body (nthcdr 3 form)) + (docstring-exp (nth 3 form)) + (body (nthcdr 4 form)) (fun (byte-compile-lambda `(lambda ,vars . ,body) nil (length env)))) - (cl-assert (> (length env) 0)) ;Otherwise, we don't need a closure. + (cl-assert (or (> (length env) 0) + docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) (byte-compile-form `(make-byte-code ',(aref fun 0) ',(aref fun 1) (vconcat (vector . ,env) ',(aref fun 2)) - ,@(nthcdr 3 (mapcar (lambda (x) `',x) fun))))))) + ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) + (if docstring-exp + `(,(car rest) + ,docstring-exp + ,@(cddr rest)) + rest))))))) (defun byte-compile-get-closed-var (form) "Byte-compile the special `internal-get-closed-var' form." @@ -3526,8 +3620,8 @@ discarding." (defun byte-compile-quo (form) (let ((len (length form))) - (cond ((<= len 2) - (byte-compile-subr-wrong-args form "2 or more")) + (cond ((< len 2) + (byte-compile-subr-wrong-args form "1 or more")) ((= len 3) (byte-compile-two-args form)) (t @@ -3580,7 +3674,7 @@ discarding." (byte-compile-constant (if (eq 'lambda (car-safe f)) (byte-compile-lambda f) f)))) - + (defun byte-compile-indent-to (form) (let ((len (length form))) (cond ((= len 2) @@ -3738,11 +3832,11 @@ discarding." "Execute forms in BODY, potentially guarded by CONDITION. CONDITION is a variable whose value is a test in an `if' or `cond'. BODY is the code to compile in the first arm of the if or the body of -the cond clause. If CONDITION's value is of the form (fboundp 'foo) -or (boundp 'foo), the relevant warnings from BODY about foo's +the cond clause. If CONDITION's value is of the form (fboundp \\='foo) +or (boundp \\='foo), the relevant warnings from BODY about foo's being undefined (or obsolete) will be suppressed. -If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs), +If CONDITION's value is (not (featurep \\='emacs)) or (featurep \\='xemacs), that suppresses all warnings during execution of BODY." (declare (indent 1) (debug t)) `(let* ((fbound-list (byte-compile-find-bound-condition @@ -3757,6 +3851,10 @@ that suppresses all warnings during execution of BODY." ;; If things not being bound at all is ok, so must them being ;; obsolete. Note that we add to the existing lists since Tramp ;; (ab)uses this feature. + ;; FIXME: If `foo' is obsoleted by `bar', the code below + ;; correctly arranges to silence the warnings after testing + ;; existence of `foo', but the warning should also be + ;; silenced after testing the existence of `bar'. (let ((byte-compile-not-obsolete-vars (append byte-compile-not-obsolete-vars bound-list)) (byte-compile-not-obsolete-funcs @@ -4026,36 +4124,46 @@ binding slots have been popped." (byte-defop-compiler-1 save-restriction) ;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro. ;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro. -(byte-defop-compiler-1 track-mouse) + +(defvar byte-compile--use-old-handlers nil + "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)) -(defun byte-compile-track-mouse (form) - (byte-compile-form - (pcase form - (`(,_ :fun-body ,f) `(eval (list 'track-mouse (list 'funcall ,f)))) - (_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form)))))))) - (defun byte-compile-condition-case (form) + (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 @@ -4106,6 +4214,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)))) @@ -4260,7 +4424,7 @@ binding slots have been popped." ;; which is to call back byte-compile-file-form and then return nil. ;; Except that we can't just call byte-compile-file-form since it would ;; call us right back. - (t (byte-compile-keep-pending form))))) + (_ (byte-compile-keep-pending form))))) (byte-defop-compiler-1 with-no-warnings byte-compile-no-warnings) (defun byte-compile-no-warnings (form) @@ -4368,11 +4532,11 @@ whose definitions have been compiled in this Emacs session, as well as all functions called by those functions. The call graph does not include macros, inline functions, or -primitives that the byte-code interpreter knows about directly \(eq, -cons, etc.\). +primitives that the byte-code interpreter knows about directly +\(`eq', `cons', etc.). The call tree also lists those functions which are not known to be called -\(that is, to which no calls have been compiled\), and which cannot be +\(that is, to which no calls have been compiled), and which cannot be invoked interactively." (interactive) (message "Generating call tree...") diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 70fa71a0da4..efa9a3da011 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 -*- +;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*- -;; Copyright (C) 2011-2013 Free Software Foundation, Inc. +;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp ;; Package: emacs @@ -30,13 +30,13 @@ ;; All macros should be expanded beforehand. ;; ;; Here is a brief explanation how this code works. -;; Firstly, we analyze the tree by calling cconv-analyse-form. +;; Firstly, we analyze the tree by calling cconv-analyze-form. ;; This function finds all mutated variables, all functions that are suitable ;; for lambda lifting and all variables captured by closure. It passes the tree ;; once, returning a list of three lists. ;; ;; Then we calculate the intersection of the first and third lists returned by -;; cconv-analyse form to find all mutated variables that are captured by +;; cconv-analyze form to find all mutated variables that are captured by ;; closure. ;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the @@ -48,14 +48,14 @@ ;; if the function is suitable for lambda lifting (if all calls are known) ;; ;; (lambda (v0 ...) ... fv0 .. fv1 ...) => -;; (internal-make-closure (v0 ...) (fv1 ...) +;; (internal-make-closure (v0 ...) (fv0 ...) <doc> ;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...) ;; ;; If the function has no free variables, we don't do anything. ;; ;; If a variable is mutated (updated by setq), and it is used in a closure ;; we wrap its definition with list: (list val) and we also replace -;; var => (car var) wherever this variable is used, and also +;; 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 @@ -65,6 +65,14 @@ ;; ;;; Code: +;; PROBLEM cases found during conversion to lexical binding. +;; We should try and detect and warn about those cases, even +;; for lexical-binding==nil to help prepare the migration. +;; - Uses of run-hooks, and friends. +;; - Cases where we want to apply the same code to different vars depending on +;; some test. These sometimes use a (let ((foo (if bar 'a 'b))) +;; ... (symbol-value foo) ... (set foo ...)). + ;; TODO: (not just for cconv but also for the lexbind changes in general) ;; - let (e)debug find the value of lexical variables from the stack. ;; - make eval-region do the eval-sexp-add-defvars dance. @@ -79,8 +87,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. +;; - 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, @@ -88,9 +95,8 @@ ;; the bytecomp only compiles it once. ;; - Since we know here when a variable is not mutated, we could pass that ;; info to the byte-compiler, e.g. by using a new `immutable-let'. -;; - add tail-calls to bytecode.c and the byte compiler. ;; - call known non-escaping functions with `goto' rather than `call'. -;; - optimize mapcar to a while loop. +;; - optimize mapc to a dolist loop. ;; (defmacro dlet (binders &rest body) ;; ;; Works in both lexical and non-lexical mode. @@ -141,7 +147,7 @@ Returns a form where all lambdas don't have any free variables." (cconv-lambda-candidates '()) (cconv-captured+mutated '())) ;; Analyze form - fill these variables with new information. - (cconv-analyse-form form '()) + (cconv-analyze-form form '()) (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) (prog1 (cconv-convert form nil nil) ; Env initially empty. (cl-assert (null cconv-freevars-alist))))) @@ -153,7 +159,7 @@ Returns a form where all lambdas don't have any free variables." (cconv-lambda-candidates '()) (cconv-captured+mutated '())) ;; Analyze form - fill these variables with new information. - (cconv-analyse-form form '()) + (cconv-analyze-form form '()) ;; But don't perform the closure conversion. form)) @@ -196,7 +202,7 @@ Returns a form where all lambdas don't have any free variables." (unless (memq (car b) s) (push b res))) (nreverse res))) -(defun cconv--convert-function (args body env parentform) +(defun cconv--convert-function (args body env parentform &optional docstring) (cl-assert (equal body (caar cconv-freevars-alist))) (let* ((fvs (cdr (pop cconv-freevars-alist))) (body-new '()) @@ -211,9 +217,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)))) @@ -224,7 +230,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) @@ -241,11 +247,11 @@ Returns a form where all lambdas don't have any free variables." `(,@(nreverse special-forms) (let ,letbind . ,body-new))))) (cond - ((null envector) ;if no freevars - do nothing + ((not (or envector docstring)) ;If no freevars - do nothing. `(function (lambda ,args . ,body-new))) (t `(internal-make-closure - ,args ,envector . ,body-new))))) + ,args ,envector ,docstring . ,body-new))))) (defun cconv-convert (form env extend) ;; This function actually rewrites the tree. @@ -254,7 +260,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. @@ -290,12 +296,16 @@ 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-message "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 @@ -320,9 +330,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 @@ -332,7 +342,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. @@ -405,7 +415,9 @@ places where they originally did not directly appear." cond-forms))) (`(function (lambda ,args . ,body) . ,_) - (cconv--convert-function args body env form)) + (let ((docstring (if (eq :documentation (car-safe (car body))) + (cconv-convert (cadr (pop body)) env extend)))) + (cconv--convert-function args body env form docstring))) (`(internal-make-closure . ,_) (byte-compile-report-error @@ -421,25 +433,45 @@ 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))) - (`(track-mouse . ,body) - `(track-mouse - :fun-body ,(cconv--convert-function () body env form))) - (`(setq . ,forms) ; setq special form (let ((prognlist ())) (while forms @@ -448,7 +480,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. @@ -472,7 +504,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) @@ -491,7 +523,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))) @@ -503,7 +535,7 @@ places where they originally did not directly appear." (defalias 'byte-compile-not-lexical-var-p 'boundp)) (defvar byte-compile-lexical-variables) -(defun cconv--analyse-use (vardata form varkind) +(defun cconv--analyze-use (vardata form varkind) "Analyze the use of a variable. VARDATA should be (BINDER READ MUTATED CAPTURED CALLED). VARKIND is the name of the kind of variable. @@ -511,10 +543,10 @@ FORM is the parent form that binds this var." ;; use = `(,binder ,read ,mutated ,captured ,called) (pcase vardata (`(,_ nil nil nil nil) nil) - (`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_) + (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_) ,_ ,_ ,_ ,_) (byte-compile-log-warning - (format "%s `%S' not left unused" varkind var)))) + (format-message "%s `%S' not left unused" varkind var)))) (pcase vardata (`((,var . ,_) nil ,_ ,_ nil) ;; FIXME: This gives warnings in the wrong order, with imprecise line @@ -526,8 +558,8 @@ FORM is the parent form that binds this var." (eq ?_ (aref (symbol-name var) 0)) ;; As a special exception, ignore "ignore". (eq var 'ignored)) - (byte-compile-log-warning (format "Unused lexical %s `%S'" - varkind var)))) + (byte-compile-log-warning (format-message "Unused lexical %s `%S'" + varkind var)))) ;; If it's unused, there's no point converting it into a cons-cell, even if ;; it's captured and mutated. (`(,binder ,_ t t ,_) @@ -535,7 +567,7 @@ FORM is the parent form that binds this var." (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) (push (cons binder form) cconv-lambda-candidates)))) -(defun cconv--analyse-function (args body env parentform) +(defun cconv--analyze-function (args body env parentform) (let* ((newvars nil) (freevars (list body)) ;; We analyze the body within a new environment where all uses are @@ -552,17 +584,18 @@ 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. - (cconv-analyse-form form newenv)) + (cconv-analyze-form form newenv)) ;; Summarize resulting data about arguments. (dolist (vardata newvars) - (cconv--analyse-use vardata parentform "argument")) + (cconv--analyze-use vardata parentform "argument")) ;; Transfer uses collected in `envcopy' (via `newenv') back to `env'; ;; and compute free variables. (while env @@ -578,7 +611,7 @@ FORM is the parent form that binds this var." (setf (nth 3 (car env)) t)) (setq env (cdr env) envcopy (cdr envcopy)))))) -(defun cconv-analyse-form (form env) +(defun cconv-analyze-form (form env) "Find mutated variables and variables captured by closure. Analyze lambdas if they are suitable for lambda lifting. - FORM is a piece of Elisp code after macroexpansion. @@ -605,7 +638,7 @@ and updates the data stored in ENV." (setq var (car binder)) (setq value (cadr binder)) - (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) + (cconv-analyze-form value (if (eq letsym 'let*) env orig-env))) (unless (byte-compile-not-lexical-var-p var) (cl-pushnew var byte-compile-lexical-variables) @@ -614,13 +647,15 @@ and updates the data stored in ENV." (push varstruct env)))) (dolist (form body-forms) ; Analyze body forms. - (cconv-analyse-form form env)) + (cconv-analyze-form form env)) (dolist (vardata newvars) - (cconv--analyse-use vardata form "variable")))) + (cconv--analyze-use vardata form "variable")))) (`(function (lambda ,vrs . ,body-forms)) - (cconv--analyse-function vrs body-forms env form)) + (when (eq :documentation (car-safe (car body-forms))) + (cconv-analyze-form (cadr (pop body-forms)) env)) + (cconv--analyze-function vrs body-forms env form)) (`(setq . ,forms) ;; If a local variable (member of env) is modified by setq then @@ -628,7 +663,7 @@ and updates the data stored in ENV." (while forms (let ((v (assq (car forms) env))) ; v = non nil if visible (when v (setf (nth 2 v) t))) - (cconv-analyse-form (cadr forms) env) + (cconv-analyze-form (cadr forms) env) (setq forms (cddr forms)))) (`((lambda . ,_) . ,_) ; First element is lambda expression. @@ -636,37 +671,52 @@ and updates the data stored in ENV." (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))) + (cconv-analyze-form exp env))) (`(cond . ,cond-forms) ; cond special form (dolist (forms cond-forms) - (dolist (form forms) (cconv-analyse-form form env)))) + (dolist (form forms) (cconv-analyze-form form env)))) + + ;; ((and `(quote ,v . ,_) (guard (assq v env))) + ;; (byte-compile-log-warning + ;; (format-message "Possible confusion variable/symbol for `%S'" v))) (`(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). - (cconv--analyse-function () (list protected-form) env form) + ;; form and handlers in closures. + (cconv--analyze-function () (list protected-form) env form) (dolist (handler handlers) - (cconv--analyse-function (if var (list var)) (cdr handler) env form))) + (cconv--analyze-function (if var (list var)) (cdr handler) + env form))) - ;; FIXME: The bytecode for catch forces us to wrap the body. - (`(,(or `catch `unwind-protect) ,form . ,body) - (cconv-analyse-form form env) - (cconv--analyse-function () body env form)) - - ;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body. - ;; `track-mouse' really should be made into a macro. - (`(track-mouse . ,body) - (cconv--analyse-function () body env form)) + (`(condition-case ,var ,protected-form . ,handlers) + (cconv-analyze-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-analyze-form form env))) + (if var (cconv--analyze-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-analyze-form form env) + (cconv--analyze-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)) + (cconv-analyze-form value env)) (`(,(or `funcall `apply) ,fun . ,args) ;; Here we ignore fun because funcall and apply are the only two @@ -676,8 +726,8 @@ and updates the data stored in ENV." (let ((fdata (and (symbolp fun) (assq fun env)))) (if fdata (setf (nth 4 fdata) t) - (cconv-analyse-form fun env))) - (dolist (form args) (cconv-analyse-form form env))) + (cconv-analyze-form fun env))) + (dolist (form args) (cconv-analyze-form form env))) (`(interactive . ,forms) ;; These appear within the function body but they don't have access @@ -685,19 +735,20 @@ and updates the data stored in ENV." ;; We could extend this to allow interactive specs to refer to ;; variables in the function's enclosing environment, but it doesn't ;; seem worth the trouble. - (dolist (form forms) (cconv-analyse-form form nil))) + (dolist (form forms) (cconv-analyze-form form nil))) ;; `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))) + (dolist (form body-forms) (cconv-analyze-form form env))) ((pred symbolp) (let ((dv (assq form env))) ; dv = declared and visible (when dv (setf (nth 1 dv) t)))))) +(define-obsolete-function-alias 'cconv-analyse-form 'cconv-analyze-form "25.1") (provide 'cconv) ;;; cconv.el ends here diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 032eced7592..06601252a4c 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-2015 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 ()) @@ -280,7 +280,7 @@ START and END represent the boundary." "Draw axis information based upon a range to be spread along the edge. A is the chart to draw. DIR is the direction. MARGIN, ZONE, START, and END specify restrictions in chart space." - (call-next-method) + (cl-call-next-method) ;; We prefer about 5 spaces between each value (let* ((i (car (oref a bounds))) (e (cdr (oref a bounds))) @@ -333,7 +333,7 @@ Automatically compensates for direction." "Draw axis information based upon A range to be spread along the edge. Optional argument DIR is the direction of the chart. Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing." - (call-next-method) + (cl-call-next-method) ;; We prefer about 5 spaces between each value (let* ((i 0) (s (oref a items)) @@ -422,7 +422,7 @@ or is created with the bounds of SEQ." (if (stringp (car (oref seq data))) (let ((labels (oref seq data))) (if (not axis) - (setq axis (make-instance chart-axis-names + (setq axis (make-instance 'chart-axis-names :name (oref seq name) :items labels :chart c)) @@ -430,7 +430,7 @@ or is created with the bounds of SEQ." (let ((range (cons 0 1)) (l (oref seq data))) (if (not axis) - (setq axis (make-instance chart-axis-range + (setq axis (make-instance 'chart-axis-range :name (oref seq name) :chart c))) (while l @@ -577,19 +577,19 @@ labeled NUMTITLE. Optional arguments: Set the chart's max element display to MAX, and sort lists with SORT-PRED if desired." - (let ((nc (make-instance chart-bar + (let ((nc (make-instance 'chart-bar :title title :key-label "8-m" ; This is a text key pic :direction dir )) (iv (eq dir 'vertical))) (chart-add-sequence nc - (make-instance chart-sequece + (make-instance 'chart-sequece :data namelst :name nametitle) (if iv 'x-axis 'y-axis)) (chart-add-sequence nc - (make-instance chart-sequece + (make-instance 'chart-sequece :data numlst :name numtitle) (if iv 'y-axis 'x-axis)) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 367db5240c9..536e4186c41 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-2015 Free Software Foundation, Inc. ;; Author: Glenn Morris <rgm@gnu.org> ;; Keywords: lisp, tools, maint @@ -98,7 +98,7 @@ don't know how to recognize (e.g. some macros)." (stringp (setq fnfile (nth 2 form))) (setq fnfile (check-declare-locate fnfile (expand-file-name file))) - ;; Use `t' to distinguish unspecified arglist from empty one. + ;; Use t to distinguish unspecified arglist from empty one. (or (eq t (setq arglist (if (> len 3) (nth 3 form) t))) @@ -125,6 +125,14 @@ With optional argument FULL, sums the number of elements in each element." (autoload 'byte-compile-arglist-signature "bytecomp") +(defgroup check-declare nil + "Check declare-function statements." + :group 'tools) + +(defcustom check-declare-ext-errors nil + "When non-nil, warn about functions not found in :ext." + :type 'boolean) + (defun check-declare-verify (fnfile fnlist) "Check that FNFILE contains function definitions matching FNLIST. Each element of FNLIST has the form (FILE FN ARGLIST FILEONLY), where @@ -149,11 +157,12 @@ is a string giving details of the error." (setq re (format (if cflag "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\"" "^[ \t]*(\\(fset[ \t]+'\\|\ +cl-def\\(?:generic\\|method\\)\\|\ def\\(?:un\\|subst\\|foo\\|method\\|class\\|\ ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\\|\ \\(?:ine-obsolete-function-\\)?alias[ \t]+'\\|\ ine-overloadable-function\\)\\)\ -\[ \t]*%s\\([ \t;]+\\|$\\)") +[ \t]*%s\\([ \t;]+\\|$\\)") (regexp-opt (mapcar 'cadr fnlist) t))) (while (re-search-forward re nil t) (skip-chars-forward " \t\n") @@ -192,8 +201,8 @@ ine-overloadable-function\\)\\)\ type) 'obsolete) ;; Can't easily check arguments in these cases. - ((string-match "\\`\\(def\\(alias\\|\ -method\\|class\\)\\|fset\\)\\>" type) + ((string-match "\\`\\(def\\(alias\\|class\\)\\|\ +fset\\|\\(?:cl-\\)?defmethod\\)\\>" type) t) ((looking-at "\\((\\|nil\\)") (byte-compile-arglist-signature @@ -226,7 +235,8 @@ method\\|class\\)\\|fset\\)\\>" type) (when type (setq errlist (cons (list (car e) (cadr e) type) errlist)))) (message "%s%s" m - (if (or re (not ext)) + (if (or re (or check-declare-ext-errors + (not ext))) (check-declare-errmsg errlist) (progn (setq errlist nil) @@ -251,12 +261,29 @@ Returned list has elements FNFILE (FILE ...)." "Warn that FILE made a false claim about FN in FNFILE. TYPE is a string giving the nature of the error. Warning is displayed in `check-declare-warning-buffer'." - (display-warning 'check-declare - (format "%s said `%s' was defined in %s: %s" - (file-name-nondirectory file) fn - (file-name-nondirectory fnfile) - type) - nil check-declare-warning-buffer)) + (let ((warning-prefix-function + (lambda (level entry) + (let ((line 0) + (col 0)) + (insert + (with-current-buffer (find-file-noselect file) + (goto-char (point-min)) + (when (re-search-forward + (format "(declare-function[ \t\n]+%s" fn) nil t) + (goto-char (match-beginning 0)) + (setq line (line-number-at-pos)) + (setq col (1+ (current-column)))) + (format "%s:%d:%d:" + (file-name-nondirectory file) + line col)))) + entry)) + (warning-fill-prefix " ")) + (display-warning 'check-declare + (format-message "said `%s' was defined in %s: %s" + fn (file-name-nondirectory fnfile) type) + nil check-declare-warning-buffer))) + +(declare-function compilation-forget-errors "compile" ()) (defun check-declare-files (&rest files) "Check veracity of all `declare-function' statements in FILES. @@ -269,13 +296,20 @@ Return a list of any errors found." (dolist (e (check-declare-sort alist)) (if (setq err (check-declare-verify (car e) (cdr e))) (setq errlist (cons (cons (car e) err) errlist)))) + (setq errlist (nreverse errlist)) (if (get-buffer check-declare-warning-buffer) (kill-buffer check-declare-warning-buffer)) + (with-current-buffer (get-buffer-create check-declare-warning-buffer) + (unless (derived-mode-p 'compilation-mode) + (compilation-mode)) + (let ((inhibit-read-only t)) + (insert "\f\n")) + (compilation-forget-errors)) ;; Sort back again so that errors are ordered by the files ;; containing the declare-function statements. (dolist (e (check-declare-sort errlist)) - (dolist (f (cdr e)) - (check-declare-warn (car e) (cadr f) (car f) (nth 2 f)))) + (dolist (f (cdr e)) + (check-declare-warn (car e) (cadr f) (car f) (nth 2 f)))) errlist)) ;;;###autoload diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 9c5b408637f..bf1a21acaf1 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 +;;; checkdoc.el --- check documentation strings for style requirements -*- lexical-binding:t -*- -;; Copyright (C) 1997-1998, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1997-1998, 2001-2015 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.6.2 @@ -267,6 +267,11 @@ made in the style guide relating to order." :type 'boolean) ;;;###autoload(put 'checkdoc-arguments-in-order-flag 'safe-local-variable #'booleanp) +(defcustom checkdoc-package-keywords-flag nil + "Non-nil means warn if this file's package keywords are not recognized. +Currently, all recognized keywords must be on `finder-known-keywords'." + :type 'boolean) + (define-obsolete-variable-alias 'checkdoc-style-hooks 'checkdoc-style-functions "24.3") (defvar checkdoc-style-functions nil @@ -315,6 +320,7 @@ This should be set in an Emacs Lisp file's local variables." ;;;###autoload (defun checkdoc-list-of-strings-p (obj) + "Return t when OBJ is a list of strings." ;; 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) @@ -741,7 +747,7 @@ buffer, otherwise searching starts at START-HERE." ;; Loop over docstrings. (while (checkdoc-next-docstring) (message "Searching for doc string spell error...%d%%" - (/ (* 100 (point)) (point-max))) + (floor (* 100.0 (point)) (point-max))) (if (looking-at "\"") (checkdoc-ispell-docstring-engine (save-excursion (forward-sexp 1) (point-marker))))) @@ -761,7 +767,7 @@ buffer, otherwise searching starts at START-HERE." ;; Loop over message strings. (while (checkdoc-message-text-next-string (point-max)) (message "Searching for message string spell error...%d%%" - (/ (* 100 (point)) (point-max))) + (floor (* 100.0 (point)) (point-max))) (if (looking-at "\"") (checkdoc-ispell-docstring-engine (save-excursion (forward-sexp 1) (point-marker))))) @@ -785,7 +791,7 @@ perform the fix." (condition-case nil (while (and (not msg) (checkdoc-next-docstring)) (message "Searching for doc string error...%d%%" - (/ (* 100 (point)) (point-max))) + (floor (* 100.0 (point)) (point-max))) (if (setq msg (checkdoc-this-string-valid)) (setq msg (cons msg (point))))) ;; Quit.. restore position, Other errors, leave alone @@ -807,7 +813,7 @@ assumes that the cursor is already positioned to perform the fix." (setq type (checkdoc-message-text-next-string (point-max)))) (message "Searching for message string error...%d%%" - (/ (* 100 (point)) (point-max))) + (floor (* 100.0 (point)) (point-max))) (if (setq msg (checkdoc-message-text-engine type)) (setq msg (cons msg (point))))) ;; Quit.. restore position, Other errors, leave alone @@ -866,11 +872,20 @@ otherwise stop after the first error." (checkdoc-start) (checkdoc-message-text) (checkdoc-rogue-spaces) + (when checkdoc-package-keywords-flag + (checkdoc-package-keywords)) (not (called-interactively-p 'interactive)) (if take-notes (checkdoc-show-diagnostics)) (message "Checking buffer for style...Done.")))) ;;;###autoload +(defun checkdoc-file (file) + "Check FILE for document, comment, error style, and rogue spaces." + (with-current-buffer (find-file-noselect file) + (let ((checkdoc-diagnostic-buffer "*warn*")) + (checkdoc-current-buffer t)))) + +;;;###autoload (defun checkdoc-start (&optional take-notes) "Start scanning the current buffer for documentation string style errors. Only documentation strings are checked. @@ -1404,7 +1419,7 @@ regexp short cuts work. FP is the function defun information." (when (re-search-forward "^(" e t) (if (checkdoc-autofix-ask-replace (match-beginning 0) (match-end 0) - "Escape this '('? " + (format-message "Escape this `('? ") "\\(") nil (checkdoc-create-error @@ -1524,7 +1539,7 @@ may require more formatting") ;; Instead, use the `\\[...]' construct to stand for them. (save-excursion (let ((f nil) (m nil) (start (point)) - (re "[^`A-Za-z0-9_]\\([CMA]-[a-zA-Z]\\|\\(\\([CMA]-\\)?\ + (re "[^`‘A-Za-z0-9_]\\([CMA]-[a-zA-Z]\\|\\(\\([CMA]-\\)?\ mouse-[0-3]\\)\\)\\>")) ;; Find the first key sequence not in a sample (while (and (not f) (setq m (re-search-forward re e t))) @@ -1554,7 +1569,8 @@ mouse-[0-3]\\)\\)\\>")) (save-excursion (let ((case-fold-search t) (ret nil) mb me) - (while (and (re-search-forward "`\\(\\sw\\(\\sw\\|\\s_\\)+\\)'" e t) + (while (and (re-search-forward + "[`‘]\\(\\sw\\(\\sw\\|\\s_\\)+\\)['’]" e t) (not ret)) (let* ((ms1 (match-string 1)) (sym (intern-soft ms1))) @@ -1615,8 +1631,8 @@ function,command,variable,option or symbol." ms1)))))) (or ;; * The documentation string for a variable that is a ;; yes-or-no flag should start with words such as Non-nil - ;; means..., to make it clear that all non-`nil' values are - ;; equivalent and indicate explicitly what `nil' and non-`nil' + ;; means..., to make it clear that all non-nil values are + ;; equivalent and indicate explicitly what nil and non-nil ;; mean. ;; * If a user option variable records a true-or-false ;; condition, give it a name that ends in `-flag'. @@ -1663,14 +1679,15 @@ function,command,variable,option or symbol." ms1)))))) ;; Addendum: Make sure they appear in the doc in the same ;; order that they are found in the arg list. - (let ((args (cdr (cdr (cdr (cdr fp))))) + (let ((args (nthcdr 4 fp)) (last-pos 0) (found 1) (order (and (nth 3 fp) (car (nth 3 fp)))) (nocheck (append '("&optional" "&rest") (nth 3 fp))) (inopts nil)) (while (and args found (> found last-pos)) - (if (member (car args) nocheck) + (if (or (member (car args) nocheck) + (string-match "\\`_" (car args))) (setq args (cdr args) inopts t) (setq last-pos found @@ -1697,7 +1714,7 @@ function,command,variable,option or symbol." ms1)))))) e t)) (if (checkdoc-autofix-ask-replace (match-beginning 1) (match-end 1) - (format + (format-message "If this is the argument `%s', it should appear as %s. Fix? " (car args) (upcase (car args))) (upcase (car args)) t) @@ -1723,7 +1740,7 @@ function,command,variable,option or symbol." ms1)))))) (insert ".")) nil) (checkdoc-create-error - (format + (format-message "Argument `%s' should appear (as %s) in the doc string" (car args) (upcase (car args))) s (marker-position e))) @@ -1784,16 +1801,17 @@ Replace with \"%s\"? " original replace) ))) ;;* When a documentation string refers to a Lisp symbol, write it as ;; it would be printed (which usually means in lower case), with - ;; single-quotes around it. For example: `lambda'. There are two - ;; exceptions: write t and nil without single-quotes. (In this - ;; manual, we normally do use single-quotes for those symbols.) + ;; single-quotes around it. For example: ‘lambda’. There are two + ;; exceptions: write t and nil without single-quotes. (For + ;; compatibility with an older Emacs style, quoting with ` and ' + ;; also works, e.g., `lambda' is treated like ‘lambda’.) (save-excursion (let ((found nil) (start (point)) (msg nil) (ms nil)) (while (and (not msg) (re-search-forward ;; Ignore manual page references like ;; git-config(1). - "[^-([`':a-zA-Z]\\(\\w+[:-]\\(\\w\\|\\s_\\)+\\)[^](']" + "[^-([`'‘’:a-zA-Z]\\(\\w+[:-]\\(\\w\\|\\s_\\)+\\)[^]('’]" e t)) (setq ms (match-string 1)) ;; A . is a \s_ char, so we must remove periods from @@ -1806,16 +1824,16 @@ Replace with \"%s\"? " original replace) (setq found (intern-soft ms)) (or (boundp found) (fboundp found))) (progn - (setq msg (format "Add quotes around Lisp symbol `%s'? " - ms)) + (setq msg (format-message + "Add quotes around Lisp symbol `%s'? " ms)) (if (checkdoc-autofix-ask-replace (match-beginning 1) (+ (match-beginning 1) (length ms)) - msg (concat "`" ms "'") t) + msg (format-message "`%s'" ms) t) (setq msg nil) (setq msg - (format "Lisp symbol `%s' should appear in quotes" - ms)))))) + (format-message + "Lisp symbol `%s' should appear in quotes" ms)))))) (if msg (checkdoc-create-error msg (match-beginning 1) (+ (match-beginning 1) @@ -1823,7 +1841,7 @@ Replace with \"%s\"? " original replace) nil))) ;; t and nil case (save-excursion - (if (re-search-forward "\\(`\\(t\\|nil\\)'\\)" e t) + (if (re-search-forward "\\([`‘]\\(t\\|nil\\)['’]\\)" e t) (if (checkdoc-autofix-ask-replace (match-beginning 1) (match-end 1) (format "%s should not appear in quotes. Remove? " @@ -1831,7 +1849,7 @@ Replace with \"%s\"? " original replace) (match-string 2) t) nil (checkdoc-create-error - "Symbols t and nil should not appear in `...' quotes" + "Symbols t and nil should not appear in single quotes" (match-beginning 1) (match-end 1))))) ;; Here is some basic sentence formatting (checkdoc-sentencespace-region-engine (point) e) @@ -1936,7 +1954,7 @@ from the comment." "Return non-nil if the current point is in a code fragment. A code fragment is identified by an open parenthesis followed by a symbol which is a valid function or a word in all CAPS, or a parenthesis -that is quoted with the ' character. Only the region from START to LIMIT +that is quoted with the \\=' character. Only the region from START to LIMIT is allowed while searching for the bounding parenthesis." (save-match-data (save-restriction @@ -1988,7 +2006,7 @@ If the offending word is in a piece of quoted text, then it is skipped." (if (and (not (save-excursion (goto-char b) (forward-char -1) - (looking-at "`\\|\"\\|\\.\\|\\\\"))) + (looking-at "[`\".‘]\\|\\\\"))) ;; surrounded by /, as in a URL or filename: /emacs/ (not (and (= ?/ (char-after e)) (= ?/ (char-before b)))) @@ -2404,7 +2422,7 @@ Argument END is the maximum bounds to search in." According to the documentation for the function `error', the error list should not end with a period, and should start with a capital letter. The function `y-or-n-p' has similar constraints. -Argument TYPE specifies the type of question, such as `error or `y-or-n-p." +Argument TYPE specifies the type of question, such as `error' or `y-or-n-p'." ;; If type is nil, then attempt to derive it. (if (not type) (save-excursion @@ -2469,7 +2487,8 @@ Argument TYPE specifies the type of question, such as `error or `y-or-n-p." ;; If we see a ?, then replace with "? ". (if (checkdoc-autofix-ask-replace (match-beginning 0) (match-end 0) - "`y-or-n-p' argument should end with \"? \". Fix? " + (format-message + "`y-or-n-p' argument should end with \"? \". Fix? ") "? " t) nil (checkdoc-create-error @@ -2480,7 +2499,8 @@ Argument TYPE specifies the type of question, such as `error or `y-or-n-p." (looking-at " ")) (if (checkdoc-autofix-ask-replace (match-beginning 0) (match-end 0) - "`y-or-n-p' argument should end with \"? \". Fix? " + (format-message + "`y-or-n-p' argument should end with \"? \". Fix? ") "? " t) nil (checkdoc-create-error @@ -2492,7 +2512,8 @@ Argument TYPE specifies the type of question, such as `error or `y-or-n-p." (looking-at "\"")) (checkdoc-autofix-ask-replace (match-beginning 0) (match-end 0) - "`y-or-n-p' argument should end with \"? \". Fix? " + (format-message + "`y-or-n-p' argument should end with \"? \". Fix? ") "? \"" t)) nil (checkdoc-create-error @@ -2608,28 +2629,65 @@ function called to create the messages." "Store POINT and MSG as errors in the checkdoc diagnostic buffer." (setq checkdoc-pending-errors t) (let ((text (list "\n" (checkdoc-buffer-label) ":" - (int-to-string - (count-lines (point-min) (or point (point-min)))) - ": " msg))) - (with-current-buffer (get-buffer checkdoc-diagnostic-buffer) - (goto-char (point-max)) - (let ((inhibit-read-only t)) - (apply #'insert text))))) + (int-to-string + (count-lines (point-min) (or point (point-min)))) + ": " msg))) + (if (string= checkdoc-diagnostic-buffer "*warn*") + (warn (apply #'concat text)) + (with-current-buffer (get-buffer checkdoc-diagnostic-buffer) + (let ((inhibit-read-only t) + (pt (point-max))) + (goto-char pt) + (apply #'insert text)))))) (defun checkdoc-show-diagnostics () "Display the checkdoc diagnostic buffer in a temporary window." (if checkdoc-pending-errors - (let ((b (get-buffer checkdoc-diagnostic-buffer))) - (if b (progn (pop-to-buffer b) - (goto-char (point-max)) - (re-search-backward "\C-l" nil t) - (beginning-of-line) - (forward-line 1) - (recenter 0))) - (other-window -1) + (let* ((b (get-buffer checkdoc-diagnostic-buffer)) + (win (if b (display-buffer b)))) + (when win + (with-selected-window win + (goto-char (point-max)) + (re-search-backward "\C-l" nil t) + (beginning-of-line) + (forward-line 1) + (recenter 0))) (setq checkdoc-pending-errors nil) nil))) +(defun checkdoc-get-keywords () + "Return a list of package keywords for the current file." + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^;; Keywords: \\(.*\\)$" nil t) + (split-string (match-string-no-properties 1) ", " t)))) + +(defvar finder-known-keywords) + +;;;###autoload +(defun checkdoc-package-keywords () + "Find package keywords that aren't in `finder-known-keywords'." + (interactive) + (require 'finder) + (let ((unrecognized-keys + (cl-remove-if + (lambda (x) (assoc (intern-soft x) finder-known-keywords)) + (checkdoc-get-keywords)))) + (if unrecognized-keys + (let* ((checkdoc-autofix-flag 'never) + (checkdoc-generate-compile-warnings-flag t)) + (save-excursion + (goto-char (point-min)) + (re-search-forward "^;; Keywords: \\(.*\\)$" nil t) + (checkdoc-start-section "checkdoc-package-keywords") + (checkdoc-create-error + (concat "Unrecognized keywords: " + (mapconcat #'identity unrecognized-keys ", ")) + (match-beginning 1) (match-end 1))) + (checkdoc-show-diagnostics)) + (when (called-interactively-p 'any) + (message "No Package Keyword Errors."))))) + (custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode) (provide 'checkdoc) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 70ad1283cb2..afa021dffc7 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-2015 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Keywords: extensions @@ -269,43 +269,20 @@ If so, return the true (non-nil) value returned by PREDICATE. ;;;###autoload (defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) (or cl-buffer (setq cl-buffer (current-buffer))) - (if (fboundp 'overlay-lists) - - ;; This is the preferred algorithm, though overlay-lists is undocumented. - (let (cl-ovl) - (with-current-buffer cl-buffer - (setq cl-ovl (overlay-lists)) - (if cl-start (setq cl-start (copy-marker cl-start))) - (if cl-end (setq cl-end (copy-marker cl-end)))) - (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) - (while (and cl-ovl - (or (not (overlay-start (car cl-ovl))) - (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) - (and cl-start (<= (overlay-end (car cl-ovl)) cl-start)) - (not (funcall cl-func (car cl-ovl) cl-arg)))) - (setq cl-ovl (cdr cl-ovl))) - (if cl-start (set-marker cl-start nil)) - (if cl-end (set-marker cl-end nil))) - - ;; This alternate algorithm fails to find zero-length overlays. - (let ((cl-mark (with-current-buffer cl-buffer - (copy-marker (or cl-start (point-min))))) - (cl-mark2 (and cl-end (with-current-buffer cl-buffer - (copy-marker cl-end)))) - cl-pos cl-ovl) - (while (save-excursion - (and (setq cl-pos (marker-position cl-mark)) - (< cl-pos (or cl-mark2 (point-max))) - (progn - (set-buffer cl-buffer) - (setq cl-ovl (overlays-at cl-pos)) - (set-marker cl-mark (next-overlay-change cl-pos))))) - (while (and cl-ovl - (or (/= (overlay-start (car cl-ovl)) cl-pos) - (not (and (funcall cl-func (car cl-ovl) cl-arg) - (set-marker cl-mark nil))))) - (setq cl-ovl (cdr cl-ovl)))) - (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))))) + (let (cl-ovl) + (with-current-buffer cl-buffer + (setq cl-ovl (overlay-lists)) + (if cl-start (setq cl-start (copy-marker cl-start))) + (if cl-end (setq cl-end (copy-marker cl-end)))) + (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) + (while (and cl-ovl + (or (not (overlay-start (car cl-ovl))) + (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) + (and cl-start (<= (overlay-end (car cl-ovl)) cl-start)) + (not (funcall cl-func (car cl-ovl) cl-arg)))) + (setq cl-ovl (cdr cl-ovl))) + (if cl-start (set-marker cl-start nil)) + (if cl-end (set-marker cl-end nil)))) ;;; Support for `setf'. ;;;###autoload @@ -321,22 +298,21 @@ If so, return the true (non-nil) value returned by PREDICATE. ;;;###autoload (defun cl-gcd (&rest args) "Return the greatest common divisor of the arguments." - (let ((a (abs (or (pop args) 0)))) - (while args - (let ((b (abs (pop args)))) - (while (> b 0) (setq b (% a (setq a b)))))) - a)) + (let ((a (or (pop args) 0))) + (dolist (b args) + (while (/= b 0) + (setq b (% a (setq a b))))) + (abs a))) ;;;###autoload (defun cl-lcm (&rest args) "Return the least common multiple of the arguments." (if (memq 0 args) 0 - (let ((a (abs (or (pop args) 1)))) - (while args - (let ((b (abs (pop args)))) - (setq a (* (/ a (cl-gcd a b)) b)))) - a))) + (let ((a (or (pop args) 1))) + (dolist (b args) + (setq a (* (/ a (cl-gcd a b)) b))) + (abs a)))) ;;;###autoload (defun cl-isqrt (x) @@ -406,6 +382,42 @@ With two arguments, return rounding and remainder of their quotient." "Return 1 if X is positive, -1 if negative, 0 if zero." (cond ((> x 0) 1) ((< x 0) -1) (t 0))) +;;;###autoload +(cl-defun cl-parse-integer (string &key start end radix junk-allowed) + "Parse integer from the substring of STRING from START to END. +STRING may be surrounded by whitespace chars (chars with syntax ` '). +Other non-digit chars are considered junk. +RADIX is an integer between 2 and 36, the default is 10. Signal +an error if the substring between START and END cannot be parsed +as an integer unless JUNK-ALLOWED is non-nil." + (cl-check-type string string) + (let* ((start (or start 0)) + (len (length string)) + (end (or end len)) + (radix (or radix 10))) + (or (<= start end len) + (error "Bad interval: [%d, %d)" start end)) + (cl-flet ((skip-whitespace () + (while (and (< start end) + (= 32 (char-syntax (aref string start)))) + (setq start (1+ start))))) + (skip-whitespace) + (let ((sign (cl-case (and (< start end) (aref string start)) + (?+ (cl-incf start) +1) + (?- (cl-incf start) -1) + (t +1))) + digit sum) + (while (and (< start end) + (setq digit (cl-digit-char-p (aref string start) radix))) + (setq sum (+ (* (or sum 0) radix) digit) + start (1+ start))) + (skip-whitespace) + (cond ((and junk-allowed (null sum)) sum) + (junk-allowed (* sign sum)) + ((or (/= start end) (null sum)) + (error "Not an integer string: `%s'" string)) + (t (* sign sum))))))) + ;; Random numbers. @@ -417,7 +429,7 @@ Optional second arg STATE is a random-state object." ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. (let ((vec (aref state 3))) (if (integerp vec) - (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1)) + (let ((i 0) (j (- 1357335 (abs (% vec 1357333)))) (k 1)) (aset state 3 (setq vec (make-vector 55 nil))) (aset vec 0 j) (while (> (setq i (% (+ i 21) 55)) 0) @@ -485,7 +497,7 @@ This sets the values of: `cl-most-positive-float', `cl-most-negative-float', (setq cl-least-positive-normalized-float y cl-least-negative-normalized-float (- y)) ;; Divide down until value underflows to zero. - (setq x (/ 1 z) y x) + (setq x (/ z) y x) (while (condition-case _ (> (/ x 2) 0) (arith-error nil)) (setq x (/ x 2))) (setq cl-least-positive-float x @@ -505,41 +517,44 @@ This sets the values of: `cl-most-positive-float', `cl-most-negative-float', (defun cl-subseq (seq start &optional end) "Return the subsequence of SEQ from START to END. If END is omitted, it defaults to the length of the sequence. -If START or END is negative, it counts from the end." +If START or END is negative, it counts from the end. +Signal an error if START or END are outside of the sequence (i.e +too large if positive or too small if negative)." (declare (gv-setter (lambda (new) - `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) - ,new)))) - (if (stringp seq) (substring seq start end) - (let (len) - (and end (< end 0) (setq end (+ end (setq len (length seq))))) - (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) - (cond ((listp seq) - (if (> start 0) (setq seq (nthcdr start seq))) - (if end - (let ((res nil)) - (while (>= (setq end (1- end)) start) - (push (pop seq) res)) - (nreverse res)) - (copy-sequence seq))) - (t - (or end (setq end (or len (length seq)))) - (let ((res (make-vector (max (- end start) 0) nil)) - (i 0)) - (while (< start end) - (aset res i (aref seq start)) - (setq i (1+ i) start (1+ start))) - res)))))) - -;;;###autoload -(defun cl-concatenate (type &rest seqs) + (macroexp-let2 nil new new + `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) + ,new))))) + (cond ((or (stringp seq) (vectorp seq)) (substring seq start end)) + ((listp seq) + (let (len + (errtext (format "Bad bounding indices: %s, %s" start end))) + (and end (< end 0) (setq end (+ end (setq len (length seq))))) + (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) + (unless (>= start 0) + (error "%s" errtext)) + (when (> start 0) + (setq seq (nthcdr (1- start) seq)) + (or seq (error "%s" errtext)) + (setq seq (cdr seq))) + (if end + (let ((res nil)) + (while (and (>= (setq end (1- end)) start) seq) + (push (pop seq) res)) + (or (= (1+ end) start) (error "%s" errtext)) + (nreverse res)) + (copy-sequence seq)))) + (t (error "Unsupported sequence: %s" seq)))) + +;;;###autoload +(defun cl-concatenate (type &rest sequences) "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. \n(fn TYPE SEQUENCE...)" - (cond ((eq type 'vector) (apply 'vconcat seqs)) - ((eq type 'string) (apply 'concat seqs)) - ((eq type 'list) (apply 'append (append seqs '(nil)))) - (t (error "Not a sequence type name: %s" type)))) - + (pcase type + (`vector (apply #'vconcat sequences)) + (`string (apply #'concat sequences)) + (`list (apply #'append (append sequences '(nil)))) + (_ (error "Not a sequence type name: %S" type)))) ;;; List functions. @@ -575,7 +590,7 @@ If START or END is negative, it counts from the end." "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. \n(fn SYMBOL PROPNAME &optional DEFAULT)" (declare (compiler-macro cl--compiler-macro-get) - (gv-setter (lambda (store) `(put ,sym ,tag ,store)))) + (gv-setter (lambda (store) (ignore def) `(put ,sym ,tag ,store)))) (or (get sym tag) (and def ;; Make sure `def' is really absent as opposed to set to nil. @@ -593,15 +608,14 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (declare (gv-expander (lambda (do) (gv-letplace (getter setter) plist - (macroexp-let2 nil k tag - (macroexp-let2 nil d def - (funcall do `(cl-getf ,getter ,k ,d) - (lambda (v) - (macroexp-let2 nil val v - `(progn - ,(funcall setter - `(cl--set-getf ,getter ,k ,val)) - ,val)))))))))) + (macroexp-let2* nil ((k tag) (d def)) + (funcall do `(cl-getf ,getter ,k ,d) + (lambda (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, @@ -634,6 +648,13 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (progn (setplist sym (cdr (cdr plist))) t) (cl--do-remf plist tag)))) +;;; Streams. + +;;;###autoload +(defun cl-fresh-line (&optional stream) + "Output a newline unless already at the beginning of a line." + (terpri stream 'ensure)) + ;;; Some debugging aids. (defun cl-prettyprint (form) @@ -691,6 +712,171 @@ including `cl-block' and `cl-eval-when'." (prog1 (cl-prettyprint form) (message "")))) +;;; Integration into the online help system. + +(eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class. +(require 'help-mode) + +;; FIXME: We could go crazy and add another entry so describe-symbol can be +;; used with the slot names of CL structs (and/or EIEIO objects). +(add-to-list 'describe-symbol-backends + `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s)))) + +(defconst cl--typedef-regexp + (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct" + "cl-deftype" "deftype")) + "[ \t\r\n]+%s[ \t\r\n]+")) +(with-eval-after-load 'find-func + (defvar find-function-regexp-alist) + (add-to-list 'find-function-regexp-alist + `(define-type . cl--typedef-regexp))) + +(define-button-type 'cl-help-type + :supertype 'help-function-def + 'help-function #'cl-describe-type + 'help-echo (purecopy "mouse-2, RET: describe this type")) + +(define-button-type 'cl-type-definition + :supertype 'help-function-def + 'help-echo (purecopy "mouse-2, RET: find type definition")) + +(declare-function help-fns-short-filename "help-fns" (filename)) + +;;;###autoload +(defun cl-find-class (type) (cl--find-class type)) + +;;;###autoload +(defun cl-describe-type (type) + "Display the documentation for type TYPE (a symbol)." + (interactive + (let ((str (completing-read "Describe type: " obarray #'cl-find-class t))) + (if (<= (length str) 0) + (user-error "Abort!") + (list (intern str))))) + (help-setup-xref (list #'cl-describe-type type) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer standard-output + (let ((class (cl-find-class type))) + (if class + (cl--describe-class type class) + ;; FIXME: Describe other types (the built-in ones, or those from + ;; cl-deftype). + (user-error "Unknown type %S" type)))) + (with-current-buffer standard-output + ;; Return the text we displayed. + (buffer-string))))) + +(defun cl--describe-class (type &optional class) + (unless class (setq class (cl--find-class type))) + (let ((location (find-lisp-object-file-name type 'define-type)) + ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch. + (metatype (cl--class-name (symbol-value (aref class 0))))) + (insert (symbol-name type) + (substitute-command-keys " is a type (of kind `")) + (help-insert-xref-button (symbol-name metatype) + 'cl-help-type metatype) + (insert (substitute-command-keys "')")) + (when location + (insert (substitute-command-keys " in `")) + (help-insert-xref-button + (help-fns-short-filename location) + 'cl-type-definition type location 'define-type) + (insert (substitute-command-keys "'"))) + (insert ".\n") + + ;; Parents. + (let ((pl (cl--class-parents class)) + cur) + (when pl + (insert " Inherits from ") + (while (setq cur (pop pl)) + (setq cur (cl--class-name cur)) + (insert (substitute-command-keys "`")) + (help-insert-xref-button (symbol-name cur) + 'cl-help-type cur) + (insert (substitute-command-keys (if pl "', " "'")))) + (insert ".\n"))) + + ;; Children, if available. ¡For EIEIO! + (let ((ch (condition-case nil + (cl-struct-slot-value metatype 'children class) + (cl-struct-unknown-slot nil))) + cur) + (when ch + (insert " Children ") + (while (setq cur (pop ch)) + (insert (substitute-command-keys "`")) + (help-insert-xref-button (symbol-name cur) + 'cl-help-type cur) + (insert (substitute-command-keys (if ch "', " "'")))) + (insert ".\n"))) + + ;; Type's documentation. + (let ((doc (cl--class-docstring class))) + (when doc + (insert "\n" doc "\n\n"))) + + ;; Describe all the slots in this class. + (cl--describe-class-slots class) + + ;; Describe all the methods specific to this class. + (let ((generics (cl--generic-all-functions type))) + (when generics + (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) + (dolist (generic generics) + (insert (substitute-command-keys "`")) + (help-insert-xref-button (symbol-name generic) + 'help-function generic) + (insert (substitute-command-keys "'")) + (pcase-dolist (`(,qualifiers ,args ,doc) + (cl--generic-method-documentation generic type)) + (insert (format " %s%S\n" qualifiers args) + (or doc ""))) + (insert "\n\n")))))) + +(defun cl--describe-class-slot (slot) + (insert + (concat + (propertize "Slot: " 'face 'bold) + (prin1-to-string (cl--slot-descriptor-name slot)) + (unless (eq (cl--slot-descriptor-type slot) t) + (concat " type = " + (prin1-to-string (cl--slot-descriptor-type slot)))) + ;; FIXME: The default init form is treated differently for structs and for + ;; eieio objects: for structs, the default is nil, for eieio-objects + ;; it's a special "unbound" value. + (unless nil ;; (eq (cl--slot-descriptor-initform slot) eieio-unbound) + (concat " default = " + (prin1-to-string (cl--slot-descriptor-initform slot)))) + (when (alist-get :printer (cl--slot-descriptor-props slot)) + (concat " printer = " + (prin1-to-string + (alist-get :printer (cl--slot-descriptor-props slot))))) + (when (alist-get :documentation (cl--slot-descriptor-props slot)) + (concat "\n " + (substitute-command-keys + (alist-get :documentation (cl--slot-descriptor-props slot))) + "\n"))) + "\n")) + +(defun cl--describe-class-slots (class) + "Print help description for the slots in CLASS. +Outputs to the current buffer." + (let* ((slots (cl--class-slots class)) + ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch. + (metatype (cl--class-name (symbol-value (aref class 0)))) + ;; ¡For EIEIO! + (cslots (condition-case nil + (cl-struct-slot-value metatype 'class-slots class) + (cl-struct-unknown-slot nil)))) + (insert (propertize "Instance Allocated Slots:\n\n" + 'face 'bold)) + (mapc #'cl--describe-class-slot slots) + (when (> (length cslots) 0) + (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)) + (mapc #'cl--describe-class-slot cslots)))) (run-hooks 'cl-extra-load-hook) @@ -700,4 +886,5 @@ including `cl-block' and `cl-eval-when'." ;; generated-autoload-file: "cl-loaddefs.el" ;; End: +(provide 'cl-extra) ;;; cl-extra.el ends here diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el new file mode 100644 index 00000000000..aae517e8ea7 --- /dev/null +++ b/lisp/emacs-lisp/cl-generic.el @@ -0,0 +1,1159 @@ +;;; cl-generic.el --- CLOS-style generic functions for Elisp -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Version: 1.0 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This implements the most of CLOS's multiple-dispatch generic functions. +;; To use it you need either (require 'cl-generic) or (require 'cl-lib). +;; The main entry points are: `cl-defgeneric' and `cl-defmethod'. + +;; Missing elements: +;; - We don't support make-method, call-method, define-method-combination. +;; CLOS's define-method-combination is IMO overly complicated, and it suffers +;; from a significant problem: the method-combination code returns a sexp +;; that needs to be `eval'uated or compiled. IOW it requires run-time +;; code generation. Given how rarely method-combinations are used, +;; I just provided a cl-generic-combine-methods generic function, to which +;; people can add methods if they are really desperate for such functionality. +;; - In defgeneric we don't support the options: +;; declare, :method-combination, :generic-function-class, :method-class. +;; Added elements: +;; - We support aliases to generic functions. +;; - cl-generic-generalizers. This generic function lets you extend the kind +;; of thing on which to dispatch. There is support in this file for +;; dispatch on: +;; - (eql <val>) +;; - (head <val>) which checks that the arg is a cons with <val> as its head. +;; - plain old types +;; - type of CL structs +;; eieio-core adds dispatch on: +;; - class of eieio objects +;; - actual class argument, using the syntax (subclass <class>). +;; - cl-generic-combine-methods (i.s.o define-method-combination and +;; compute-effective-method). +;; - cl-generic-call-method (which replaces make-method and call-method). +;; - The standard method combination supports ":extra STRING" qualifiers +;; which simply allows adding more methods for the same +;; specializers&qualifiers. +;; - Methods can dispatch on the context. For that, a method needs to specify +;; context arguments, introduced by `&context' (which need to come right +;; after the mandatory arguments and before anything like +;; &optional/&rest/&key). Each context argument is given as (EXP SPECIALIZER) +;; which means that EXP is taken as an expression which computes some context +;; and this value is then used to dispatch. +;; E.g. (foo &context (major-mode (eql c-mode))) is an arglist specifying +;; that this method will only be applicable when `major-mode' has value +;; `c-mode'. + +;; Efficiency considerations: overall, I've made an effort to make this fairly +;; efficient for the expected case (e.g. no constant redefinition of methods). +;; - Generic functions which do not dispatch on any argument are implemented +;; optimally (just as efficient as plain old functions). +;; - Generic functions which only dispatch on one argument are fairly efficient +;; (not a lot of room for improvement without changes to the byte-compiler, +;; I think). +;; - Multiple dispatch is implemented rather naively. There's an extra `apply' +;; function call for every dispatch; we don't optimize each dispatch +;; based on the set of candidate methods remaining; we don't optimize the +;; order in which we performs the dispatches either; +;; If/when this becomes a problem, we can try and optimize it. +;; - call-next-method could be made more efficient, but isn't too terrible. + +;; TODO: +;; +;; - A generic "filter" generalizer (e.g. could be used to cleanly add methods +;; to cl-generic-combine-methods with a specializer that says it applies only +;; when some particular qualifier is used). +;; - A way to dispatch on the context (e.g. the major-mode, some global +;; variable, you name it). + +;;; Code: + +;; Note: For generic functions that dispatch on several arguments (i.e. those +;; which use the multiple-dispatch feature), we always use the same "tagcodes" +;; and the same set of arguments on which to dispatch. This works, but is +;; often suboptimal since after one dispatch, the remaining dispatches can +;; usually be simplified, or even completely skipped. + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'cl-macs)) ;For cl--find-class. +(eval-when-compile (require 'pcase)) + +(cl-defstruct (cl--generic-generalizer + (:constructor nil) + (:constructor cl-generic-make-generalizer + (name priority tagcode-function specializers-function))) + (name nil :type string) + (priority nil :type integer) + tagcode-function + specializers-function) + + +(defmacro cl-generic-define-generalizer + (name priority tagcode-function specializers-function) + "Define a new kind of generalizer. +NAME is the name of the variable that will hold it. +PRIORITY defines which generalizer takes precedence. + The catch-all generalizer has priority 0. + Then `eql' generalizer has priority 100. +TAGCODE-FUNCTION takes as first argument a varname and should return + a chunk of code that computes the tag of the value held in that variable. + Further arguments are reserved for future use. +SPECIALIZERS-FUNCTION takes as first argument a tag value TAG + and should return a list of specializers that match TAG. + Further arguments are reserved for future use." + (declare (indent 1) (debug (symbolp body))) + `(defconst ,name + (cl-generic-make-generalizer + ',name ,priority ,tagcode-function ,specializers-function))) + +(cl-generic-define-generalizer cl--generic-t-generalizer + 0 (lambda (_name &rest _) nil) (lambda (_tag &rest _) '(t))) + +(cl-defstruct (cl--generic-method + (:constructor nil) + (:constructor cl--generic-make-method + (specializers qualifiers uses-cnm function)) + (:predicate nil)) + (specializers nil :read-only t :type list) + (qualifiers nil :read-only t :type (list-of atom)) + ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument + ;; holding the next-method. + (uses-cnm nil :read-only t :type boolean) + (function nil :read-only t :type function)) + +(cl-defstruct (cl--generic + (:constructor nil) + (:constructor cl--generic-make (name)) + (:predicate nil)) + (name nil :type symbol :read-only t) ;Pointer back to the symbol. + ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index + ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP) + ;; where the EXPs are expressions (to be `or'd together) to compute the tag + ;; on which to dispatch and PRIORITY is the priority of each expression to + ;; decide in which order to sort them. + ;; The most important dispatch is last in the list (and the least is first). + (dispatches nil :type (list-of (cons natnum (list-of generalizers)))) + (method-table nil :type (list-of cl--generic-method)) + (options nil :type list)) + +(defun cl-generic-function-options (generic) + "Return the options of the generic function GENERIC." + (cl--generic-options generic)) + +(defmacro cl--generic (name) + `(get ,name 'cl--generic)) + +(defun cl-generic-ensure-function (name &optional noerror) + (let (generic + (origname name)) + (while (and (null (setq generic (cl--generic name))) + (fboundp name) + (null noerror) + (symbolp (symbol-function name))) + (setq name (symbol-function name))) + (unless (or (not (fboundp name)) + (autoloadp (symbol-function name)) + (and (functionp name) generic) + noerror) + (error "%s is already defined as something else than a generic function" + origname)) + (if generic + (cl-assert (eq name (cl--generic-name generic))) + (setf (cl--generic name) (setq generic (cl--generic-make name))) + (defalias name (cl--generic-make-function generic))) + generic)) + +;;;###autoload +(defmacro cl-defgeneric (name args &rest options-and-methods) + "Create a generic function NAME. +DOC-STRING is the base documentation for this class. A generic +function has no body, as its purpose is to decide which method body +is appropriate to use. Specific methods are defined with `cl-defmethod'. +With this implementation the ARGS are currently ignored. +OPTIONS-AND-METHODS currently understands: +- (:documentation DOCSTRING) +- (declare DECLARATIONS) +- (:argument-precedence-order &rest ARGS) +- (:method [QUALIFIERS...] ARGS &rest BODY) +BODY, if present, is used as the body of a default method. + +\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)" + (declare (indent 2) (doc-string 3)) + (let* ((doc (if (stringp (car-safe options-and-methods)) + (pop options-and-methods))) + (declarations nil) + (methods ()) + (options ()) + next-head) + (while (progn (setq next-head (car-safe (car options-and-methods))) + (or (keywordp next-head) + (eq next-head 'declare))) + (pcase next-head + (`:documentation + (when doc (error "Multiple doc strings for %S" name)) + (setq doc (cadr (pop options-and-methods)))) + (`declare + (when declarations (error "Multiple `declare' for %S" name)) + (setq declarations (pop options-and-methods))) + (`:method (push (cdr (pop options-and-methods)) methods)) + (_ (push (pop options-and-methods) options)))) + (when options-and-methods + ;; Anything remaining is assumed to be a default method body. + (push `(,args ,@options-and-methods) methods)) + (when (eq 'setf (car-safe name)) + (require 'gv) + (setq name (gv-setter (cadr name)))) + `(progn + ,@(mapcar (lambda (declaration) + (let ((f (cdr (assq (car declaration) + defun-declarations-alist)))) + (cond + (f (apply (car f) name args (cdr declaration))) + (t (message "Warning: Unknown defun property `%S' in %S" + (car declaration) name) + nil)))) + (cdr declarations)) + (defalias ',name + (cl-generic-define ',name ',args ',(nreverse options)) + ,(help-add-fundoc-usage doc args)) + ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) + (nreverse methods))))) + +;;;###autoload +(defun cl-generic-define (name args options) + (pcase-let* ((generic (cl-generic-ensure-function name 'noerror)) + (`(,spec-args . ,_) (cl--generic-split-args args)) + (mandatory (mapcar #'car spec-args)) + (apo (assq :argument-precedence-order options))) + (unless (fboundp name) + ;; If the generic function was fmakunbound, throw away previous methods. + (setf (cl--generic-dispatches generic) nil) + (setf (cl--generic-method-table generic) nil)) + (when apo + (dolist (arg (cdr apo)) + (let ((pos (memq arg mandatory))) + (unless pos (error "%S is not a mandatory argument" arg)) + (let* ((argno (- (length mandatory) (length pos))) + (dispatches (cl--generic-dispatches generic)) + (dispatch (or (assq argno dispatches) (list argno)))) + (setf (cl--generic-dispatches generic) + (cons dispatch (delq dispatch dispatches))))))) + (setf (cl--generic-options generic) options) + (cl--generic-make-function generic))) + +(defmacro cl-generic-current-method-specializers () + "List of (VAR . TYPE) where TYPE is var's specializer. +This macro can only be used within the lexical scope of a cl-generic method." + (error "cl-generic-current-method-specializers used outside of a method")) + +(defmacro cl-generic-define-context-rewriter (name args &rest body) + "Define a special kind of context named NAME. +Whenever a context specializer of the form (NAME . ACTUALS) appears, +the specializer used will be the one returned by BODY." + (declare (debug (&define name lambda-list def-body)) (indent defun)) + `(eval-and-compile + (put ',name 'cl-generic--context-rewriter + (lambda ,args ,@body)))) + +(eval-and-compile ;Needed while compiling the cl-defmethod calls below! + (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el. + "Check which of the symbols VARS appear in SEXP." + (let ((res '())) + (while (consp sexp) + (dolist (var (cl--generic-fgrep vars (pop sexp))) + (unless (memq var res) (push var res)))) + (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) + res)) + + (defun cl--generic-split-args (args) + "Return (SPEC-ARGS . PLAIN-ARGS)." + (let ((plain-args ()) + (specializers nil) + (mandatory t)) + (dolist (arg args) + (push (pcase arg + ((or '&optional '&rest '&key) (setq mandatory nil) arg) + ('&context + (unless mandatory + (error "&context not immediately after mandatory args")) + (setq mandatory 'context) nil) + ((let 'nil mandatory) arg) + ((let 'context mandatory) + (unless (consp arg) + (error "Invalid &context arg: %S" arg)) + (let* ((name (car arg)) + (rewriter + (and (symbolp name) + (get name 'cl-generic--context-rewriter)))) + (if rewriter (setq arg (apply rewriter (cdr arg))))) + (push `((&context . ,(car arg)) . ,(cadr arg)) specializers) + nil) + (`(,name . ,type) + (push (cons name (car type)) specializers) + name) + (_ + (push (cons arg t) specializers) + arg)) + plain-args)) + (cons (nreverse specializers) + (nreverse (delq nil plain-args))))) + + (defun cl--generic-lambda (args body) + "Make the lambda expression for a method with ARGS and BODY." + (pcase-let* ((`(,spec-args . ,plain-args) + (cl--generic-split-args args)) + (fun `(cl-function (lambda ,plain-args ,@body))) + (macroenv (cons `(cl-generic-current-method-specializers + . ,(lambda () spec-args)) + macroexpand-all-environment))) + (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. + ;; First macroexpand away the cl-function stuff (e.g. &key and + ;; destructuring args, `declare' and whatnot). + (pcase (macroexpand fun macroenv) + (`#'(lambda ,args . ,body) + (let* ((parsed-body (macroexp-parse-body body)) + (cnm (make-symbol "cl--cnm")) + (nmp (make-symbol "cl--nmp")) + (nbody (macroexpand-all + `(cl-flet ((cl-call-next-method ,cnm) + (cl-next-method-p ,nmp)) + ,@(cdr parsed-body)) + macroenv)) + ;; FIXME: Rather than `grep' after the fact, the + ;; macroexpansion should directly set some flag when cnm + ;; is used. + ;; FIXME: Also, optimize the case where call-next-method is + ;; only called with explicit arguments. + (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) + (cons (not (not uses-cnm)) + `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) + ,@(car parsed-body) + ,(if (not (memq nmp uses-cnm)) + nbody + `(let ((,nmp (lambda () + (cl--generic-isnot-nnm-p ,cnm)))) + ,nbody)))))) + (f (error "Unexpected macroexpansion result: %S" f)))))) + + +;;;###autoload +(defmacro cl-defmethod (name args &rest body) + "Define a new method for generic function NAME. +I.e. it defines the implementation of NAME to use for invocations where the +value of the dispatch argument matches the specified TYPE. +The dispatch argument has to be one of the mandatory arguments, and +all methods of NAME have to use the same argument for dispatch. +The dispatch argument and TYPE are specified in ARGS where the corresponding +formal argument appears as (VAR TYPE) rather than just VAR. + +The optional second argument QUALIFIER is a specifier that +modifies how the method is combined with other methods, including: + :before - Method will be called before the primary + :after - Method will be called after the primary + :around - Method will be called around everything else +The absence of QUALIFIER means this is a \"primary\" method. + +Other than a type, TYPE can also be of the form `(eql VAL)' in +which case this method will be invoked when the argument is `eql' to VAL. + +\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" + (declare (doc-string 3) (indent 2) + (debug + (&define ; this means we are defining something + [&or name ("setf" :name setf name)] + ;; ^^ This is the methods symbol + [ &optional keywordp ] ; this is key :before etc + list ; arguments + [ &optional stringp ] ; documentation string + def-body))) ; part to be debugged + (let ((qualifiers nil)) + (while (not (listp args)) + (push args qualifiers) + (setq args (pop body))) + (when (eq 'setf (car-safe name)) + (require 'gv) + (setq name (gv-setter (cadr name)))) + (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body))) + `(progn + ,(and (get name 'byte-obsolete-info) + (or (not (fboundp 'byte-compile-warning-enabled-p)) + (byte-compile-warning-enabled-p 'obsolete)) + (let* ((obsolete (get name 'byte-obsolete-info))) + (macroexp--warn-and-return + (macroexp--obsolete-warning name obsolete "generic function") + nil))) + ;; You could argue that `defmethod' modifies rather than defines the + ;; function, so warnings like "not known to be defined" are fair game. + ;; But in practice, it's common to use `cl-defmethod' + ;; without a previous `cl-defgeneric'. + (declare-function ,name "") + (cl-generic-define-method ',name ',(nreverse qualifiers) ',args + ,uses-cnm ,fun))))) + +(defun cl--generic-member-method (specializers qualifiers methods) + (while + (and methods + (let ((m (car methods))) + (not (and (equal (cl--generic-method-specializers m) specializers) + (equal (cl--generic-method-qualifiers m) qualifiers))))) + (setq methods (cdr methods))) + methods) + +;;;###autoload +(defun cl-generic-define-method (name qualifiers args uses-cnm function) + (pcase-let* + ((generic (cl-generic-ensure-function name)) + (`(,spec-args . ,_) (cl--generic-split-args args)) + (specializers (mapcar (lambda (spec-arg) + (if (eq '&context (car-safe (car spec-arg))) + spec-arg (cdr spec-arg))) + spec-args)) + (method (cl--generic-make-method + specializers qualifiers uses-cnm function)) + (mt (cl--generic-method-table generic)) + (me (cl--generic-member-method specializers qualifiers mt)) + (dispatches (cl--generic-dispatches generic)) + (i 0)) + (dolist (spec-arg spec-args) + (let* ((key (if (eq '&context (car-safe (car spec-arg))) + (car spec-arg) i)) + (generalizers (cl-generic-generalizers (cdr spec-arg))) + (x (assoc key dispatches))) + (unless x + (setq x (cons key (cl-generic-generalizers t))) + (setf (cl--generic-dispatches generic) + (setq dispatches (cons x dispatches)))) + (dolist (generalizer generalizers) + (unless (member generalizer (cdr x)) + (setf (cdr x) + (sort (cons generalizer (cdr x)) + (lambda (x y) + (> (cl--generic-generalizer-priority x) + (cl--generic-generalizer-priority y))))))) + (setq i (1+ i)))) + ;; We used to (setcar me method), but that can cause false positives in + ;; the hash-consing table of the method-builder (bug#20644). + ;; See also the related FIXME in cl--generic-build-combined-method. + (setf (cl--generic-method-table generic) + (if (null me) + (cons method mt) + ;; Keep the ordering; important for methods with :extra qualifiers. + (mapcar (lambda (x) (if (eq x (car me)) method x)) mt))) + (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) + current-load-list :test #'equal) + ;; FIXME: Try to avoid re-constructing a new function if the old one + ;; is still valid (e.g. still empty method cache)? + (let ((gfun (cl--generic-make-function generic)) + ;; Prevent `defalias' from recording this as the definition site of + ;; the generic function. + current-load-list) + ;; For aliases, cl--generic-name gives us the actual name. + (let ((purify-flag + ;; BEWARE! Don't purify this function definition, since that leads + ;; to memory corruption if the hash-tables it holds are modified + ;; (the GC doesn't trace those pointers). + nil)) + ;; But do use `defalias', so that it interacts properly with nadvice, + ;; e.g. for tracing/debug-on-entry. + (defalias (cl--generic-name generic) gfun))))) + +(defmacro cl--generic-with-memoization (place &rest code) + (declare (indent 1) (debug t)) + (gv-letplace (getter setter) place + `(or ,getter + ,(macroexp-let2 nil val (macroexp-progn code) + `(progn + ,(funcall setter val) + ,val))))) + +(defvar cl--generic-dispatchers (make-hash-table :test #'equal)) + +(defun cl--generic-get-dispatcher (dispatch) + (cl--generic-with-memoization + (gethash dispatch cl--generic-dispatchers) + ;; (message "cl--generic-get-dispatcher (%S)" dispatch) + (let* ((dispatch-arg (car dispatch)) + (generalizers (cdr dispatch)) + (lexical-binding t) + (tagcodes + (mapcar (lambda (generalizer) + (funcall (cl--generic-generalizer-tagcode-function + generalizer) + 'arg)) + generalizers)) + (typescodes + (mapcar + (lambda (generalizer) + `(funcall ',(cl--generic-generalizer-specializers-function + generalizer) + ,(funcall (cl--generic-generalizer-tagcode-function + generalizer) + 'arg))) + generalizers)) + (tag-exp + ;; Minor optimization: since this tag-exp is + ;; only used to lookup the method-cache, it + ;; doesn't matter if the default value is some + ;; constant or nil. + `(or ,@(if (macroexp-const-p (car (last tagcodes))) + (butlast tagcodes) + tagcodes))) + (fixedargs '(arg)) + (dispatch-idx dispatch-arg) + (bindings nil)) + (when (eq '&context (car-safe dispatch-arg)) + (setq bindings `((arg ,(cdr dispatch-arg)))) + (setq fixedargs nil) + (setq dispatch-idx 0)) + (dotimes (i dispatch-idx) + (push (make-symbol (format "arg%d" (- dispatch-idx i 1))) fixedargs)) + ;; FIXME: For generic functions with a single method (or with 2 methods, + ;; one of which always matches), using a tagcode + hash-table is + ;; overkill: better just use a `cl-typep' test. + (byte-compile + `(lambda (generic dispatches-left methods) + (let ((method-cache (make-hash-table :test #'eql))) + (lambda (,@fixedargs &rest args) + (let ,bindings + (apply (cl--generic-with-memoization + (gethash ,tag-exp method-cache) + (cl--generic-cache-miss + generic ',dispatch-arg dispatches-left methods + ,(if (cdr typescodes) + `(append ,@typescodes) (car typescodes)))) + ,@fixedargs args))))))))) + +(defun cl--generic-make-function (generic) + (cl--generic-make-next-function generic + (cl--generic-dispatches generic) + (cl--generic-method-table generic))) + +(defun cl--generic-make-next-function (generic dispatches methods) + (let* ((dispatch + (progn + (while (and dispatches + (let ((x (nth 1 (car dispatches)))) + ;; No need to dispatch for t specializers. + (or (null x) (equal x cl--generic-t-generalizer)))) + (setq dispatches (cdr dispatches))) + (pop dispatches)))) + (if (not (and dispatch + ;; If there's no method left, there's no point checking + ;; further arguments. + methods)) + (cl--generic-build-combined-method generic methods) + (let ((dispatcher (cl--generic-get-dispatcher dispatch))) + (funcall dispatcher generic dispatches methods))))) + +(defvar cl--generic-combined-method-memoization + (make-hash-table :test #'equal :weakness 'value) + "Table storing previously built combined-methods. +This is particularly useful when many different tags select the same set +of methods, since this table then allows us to share a single combined-method +for all those different tags in the method-cache.") + +(define-error 'cl--generic-cyclic-definition "Cyclic definition: %S") + +(defun cl--generic-build-combined-method (generic methods) + (if (null methods) + ;; Special case needed to fix a circularity during bootstrap. + (cl--generic-standard-method-combination generic methods) + (let ((f + (cl--generic-with-memoization + ;; FIXME: Since the fields of `generic' are modified, this + ;; hash-table won't work right, because the hashes will change! + ;; It's not terribly serious, but reduces the effectiveness of + ;; the table. + (gethash (cons generic methods) + cl--generic-combined-method-memoization) + (puthash (cons generic methods) :cl--generic--under-construction + cl--generic-combined-method-memoization) + (condition-case nil + (cl-generic-combine-methods generic methods) + ;; Special case needed to fix a circularity during bootstrap. + (cl--generic-cyclic-definition + (cl--generic-standard-method-combination generic methods)))))) + (if (eq f :cl--generic--under-construction) + (signal 'cl--generic-cyclic-definition + (list (cl--generic-name generic))) + f)))) + +(defun cl--generic-no-next-method-function (generic method) + (lambda (&rest args) + (apply #'cl-no-next-method generic method args))) + +(defun cl-generic-call-method (generic method &optional fun) + "Return a function that calls METHOD. +FUN is the function that should be called when METHOD calls +`call-next-method'." + (if (not (cl--generic-method-uses-cnm method)) + (cl--generic-method-function method) + (let ((met-fun (cl--generic-method-function method)) + (next (or fun (cl--generic-no-next-method-function + generic method)))) + (lambda (&rest args) + (apply met-fun + ;; FIXME: This sucks: passing just `next' would + ;; be a lot more efficient than the lambda+apply + ;; quasi-η, but we need this to implement the + ;; "if call-next-method is called with no + ;; arguments, then use the previous arguments". + (lambda (&rest cnm-args) + (apply next (or cnm-args args))) + args))))) + +;; Standard CLOS name. +(defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers) + +(defun cl--generic-standard-method-combination (generic methods) + (let ((mets-by-qual ())) + (dolist (method methods) + (let ((qualifiers (cl-method-qualifiers method))) + (if (eq (car qualifiers) :extra) (setq qualifiers (cddr qualifiers))) + (unless (member qualifiers '(() (:after) (:before) (:around))) + (error "Unsupported qualifiers in function %S: %S" + (cl--generic-name generic) qualifiers)) + (push method (alist-get (car qualifiers) mets-by-qual)))) + (cond + ((null mets-by-qual) + (lambda (&rest args) + (apply #'cl-no-applicable-method generic args))) + ((null (alist-get nil mets-by-qual)) + (lambda (&rest args) + (apply #'cl-no-primary-method generic args))) + (t + (let* ((fun nil) + (ab-call (lambda (m) (cl-generic-call-method generic m))) + (before + (mapcar ab-call (reverse (cdr (assoc :before mets-by-qual))))) + (after (mapcar ab-call (cdr (assoc :after mets-by-qual))))) + (dolist (method (cdr (assoc nil mets-by-qual))) + (setq fun (cl-generic-call-method generic method fun))) + (when (or after before) + (let ((next fun)) + (setq fun (lambda (&rest args) + (dolist (bf before) + (apply bf args)) + (prog1 + (apply next args) + (dolist (af after) + (apply af args))))))) + (dolist (method (cdr (assoc :around mets-by-qual))) + (setq fun (cl-generic-call-method generic method fun))) + fun))))) + +(defun cl--generic-arg-specializer (method dispatch-arg) + (or (if (integerp dispatch-arg) + (nth dispatch-arg + (cl--generic-method-specializers method)) + (cdr (assoc dispatch-arg + (cl--generic-method-specializers method)))) + t)) + +(defun cl--generic-cache-miss (generic + dispatch-arg dispatches-left methods-left types) + (let ((methods '())) + (dolist (method methods-left) + (let* ((specializer (cl--generic-arg-specializer method dispatch-arg)) + (m (member specializer types))) + (when m + (push (cons (length m) method) methods)))) + ;; Sort the methods, most specific first. + ;; It would be tempting to sort them once and for all in the method-table + ;; rather than here, but the order might depend on the actual argument + ;; (e.g. for multiple inheritance with defclass). + (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car)))) + (cl--generic-make-next-function generic dispatches-left methods))) + +(cl-defgeneric cl-generic-generalizers (specializer) + "Return a list of generalizers for a given SPECIALIZER. +To each kind of `specializer', corresponds a `generalizer' which describes +how to extract a \"tag\" from an object which will then let us check if this +object matches the specializer. A typical example of a \"tag\" would be the +type of an object. It's called a `generalizer' because it +takes a specific object and returns a more general approximation, +denoting a set of objects to which it belongs. +A generalizer gives us the chunk of code which the +dispatch function needs to use to extract the \"tag\" of an object, as well +as a function which turns this tag into an ordered list of +`specializers' that this object matches. +The code which extracts the tag should be as fast as possible. +The tags should be chosen according to the following rules: +- The tags should not be too specific: similar objects which match the + same list of specializers should ideally use the same (`eql') tag. + This insures that the cached computation of the applicable + methods for one object can be reused for other objects. +- Corollary: objects which don't match any of the relevant specializers + should ideally all use the same tag (typically nil). + This insures that this cache does not grow unnecessarily large. +- Two different generalizers G1 and G2 should not use the same tag + unless they use it for the same set of objects. IOW, if G1.tag(X1) = + G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2). +- If G1.priority > G2.priority and G1.tag(X1) = G1.tag(X2) and this tag is + non-nil, then you have to make sure that the G2.tag(X1) = G2.tag(X2). + This is because the method-cache is only indexed with the first non-nil + tag (by order of decreasing priority).") + +(cl-defgeneric cl-generic-combine-methods (generic methods) + "Build the effective method made of METHODS. +It should return a function that expects the same arguments as the methods, and + calls those methods in some appropriate order. +GENERIC is the generic function (mostly used for its name). +METHODS is the list of the selected methods. +The METHODS list is sorted from most specific first to most generic last. +The function can use `cl-generic-call-method' to create functions that call those +methods.") + +(unless (ignore-errors (cl-generic-generalizers t)) + ;; Temporary definition to let the next defmethod succeed. + (fset 'cl-generic-generalizers + (lambda (specializer) + (if (eq t specializer) (list cl--generic-t-generalizer)))) + (fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination)) + +(cl-defmethod cl-generic-generalizers (specializer) + "Support for the catch-all t specializer." + (if (eq specializer t) (list cl--generic-t-generalizer) + (error "Unknown specializer %S" specializer))) + +(eval-when-compile + ;; This macro is brittle and only really important in order to be + ;; able to preload cl-generic without also preloading the byte-compiler, + ;; So we use `eval-when-compile' so as not keep it available longer than + ;; strictly needed. +(defmacro cl--generic-prefill-dispatchers (arg-or-context specializer) + (unless (integerp arg-or-context) + (setq arg-or-context `(&context . ,arg-or-context))) + (unless (fboundp 'cl--generic-get-dispatcher) + (require 'cl-generic)) + (let ((fun (cl--generic-get-dispatcher + `(,arg-or-context ,@(cl-generic-generalizers specializer) + ,cl--generic-t-generalizer)))) + ;; Recompute dispatch at run-time, since the generalizers may be slightly + ;; different (e.g. byte-compiled rather than interpreted). + ;; FIXME: There is a risk that the run-time generalizer is not equivalent + ;; to the compile-time one, in which case `fun' may not be correct + ;; any more! + `(let ((dispatch `(,',arg-or-context + ,@(cl-generic-generalizers ',specializer) + ,cl--generic-t-generalizer))) + ;; (message "Prefilling for %S with \n%S" dispatch ',fun) + (puthash dispatch ',fun cl--generic-dispatchers))))) + +(cl-defmethod cl-generic-combine-methods (generic methods) + "Standard support for :after, :before, :around, and `:extra NAME' qualifiers." + (cl--generic-standard-method-combination generic methods)) + +(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t)) +(defconst cl--generic-cnm-sample + (funcall (cl--generic-build-combined-method + nil (list (cl--generic-make-method () () t #'identity))))) + +(defun cl--generic-isnot-nnm-p (cnm) + "Return non-nil if CNM is the function that calls `cl-no-next-method'." + ;; ¡Big Gross Ugly Hack! + ;; `next-method-p' just sucks, we should let it die. But EIEIO did support + ;; it, and some packages use it, so we need to support it. + (catch 'found + (cl-assert (function-equal cnm cl--generic-cnm-sample)) + (if (byte-code-function-p cnm) + (let ((cnm-constants (aref cnm 2)) + (sample-constants (aref cl--generic-cnm-sample 2))) + (dotimes (i (length sample-constants)) + (when (function-equal (aref sample-constants i) + cl--generic-nnm-sample) + (throw 'found + (not (function-equal (aref cnm-constants i) + cl--generic-nnm-sample)))))) + (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample))) + (let ((cnm-env (cadr cnm))) + (dolist (vb (cadr cl--generic-cnm-sample)) + (when (function-equal (cdr vb) cl--generic-nnm-sample) + (throw 'found + (not (function-equal (cdar cnm-env) + cl--generic-nnm-sample)))) + (setq cnm-env (cdr cnm-env))))) + (error "Haven't found no-next-method-sample in cnm-sample"))) + +;;; Define some pre-defined generic functions, used internally. + +(define-error 'cl-no-method "No method for %S") +(define-error 'cl-no-next-method "No next method for %S" 'cl-no-method) +(define-error 'cl-no-primary-method "No primary method for %S" 'cl-no-method) +(define-error 'cl-no-applicable-method "No applicable method for %S" + 'cl-no-method) + +(cl-defgeneric cl-no-next-method (generic method &rest args) + "Function called when `cl-call-next-method' finds no next method." + (signal 'cl-no-next-method `(,(cl--generic-name generic) ,method ,@args))) + +(cl-defgeneric cl-no-applicable-method (generic &rest args) + "Function called when a method call finds no applicable method." + (signal 'cl-no-applicable-method `(,(cl--generic-name generic) ,@args))) + +(cl-defgeneric cl-no-primary-method (generic &rest args) + "Function called when a method call finds no primary method." + (signal 'cl-no-primary-method `(,(cl--generic-name generic) ,@args))) + +(defun cl-call-next-method (&rest _args) + "Function to call the next applicable method. +Can only be used from within the lexical body of a primary or around method." + (error "cl-call-next-method only allowed inside primary and around methods")) + +(defun cl-next-method-p () + "Return non-nil if there is a next method. +Can only be used from within the lexical body of a primary or around method." + (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1")) + (error "cl-next-method-p only allowed inside primary and around methods")) + +;;;###autoload +(defun cl-find-method (generic qualifiers specializers) + (car (cl--generic-member-method + specializers qualifiers + (cl--generic-method-table (cl--generic generic))))) + +;;; Add support for describe-function + +(defun cl--generic-search-method (met-name) + "For `find-function-regexp-alist'. Searches for a cl-defmethod. +MET-NAME is a cons (SYMBOL . SPECIALIZERS)." + (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+" + (regexp-quote (format "%s" (car met-name))) + "\\_>"))) + (or + (re-search-forward + (concat base-re "[^&\"\n]*" + (mapconcat (lambda (specializer) + (regexp-quote + (format "%S" (if (consp specializer) + (nth 1 specializer) specializer)))) + (remq t (cdr met-name)) + "[ \t\n]*)[^&\"\n]*")) + nil t) + (re-search-forward base-re nil t)))) + +;; WORKAROUND: This can't be a defconst due to bug#21237. +(defvar cl--generic-find-defgeneric-regexp "(\\(?:cl-\\)?defgeneric[ \t]+%s\\>") + +(with-eval-after-load 'find-func + (defvar find-function-regexp-alist) + (add-to-list 'find-function-regexp-alist + `(cl-defmethod . ,#'cl--generic-search-method)) + (add-to-list 'find-function-regexp-alist + `(cl-defgeneric . cl--generic-find-defgeneric-regexp))) + +(defun cl--generic-method-info (method) + (let* ((specializers (cl--generic-method-specializers method)) + (qualifiers (cl--generic-method-qualifiers method)) + (uses-cnm (cl--generic-method-uses-cnm method)) + (function (cl--generic-method-function method)) + (args (help-function-arglist function 'names)) + (docstring (documentation function)) + (qual-string + (if (null qualifiers) "" + (cl-assert (consp qualifiers)) + (let ((s (prin1-to-string qualifiers))) + (concat (substring s 1 -1) " ")))) + (doconly (if docstring + (let ((split (help-split-fundoc docstring nil))) + (if split (cdr split) docstring)))) + (combined-args ())) + (if uses-cnm (setq args (cdr args))) + (dolist (specializer specializers) + (let ((arg (if (eq '&rest (car args)) + (intern (format "arg%d" (length combined-args))) + (pop args)))) + (push (if (eq specializer t) arg (list arg specializer)) + combined-args))) + (setq combined-args (append (nreverse combined-args) args)) + (list qual-string combined-args doconly))) + +(add-hook 'help-fns-describe-function-functions #'cl--generic-describe) +(defun cl--generic-describe (function) + ;; Supposedly this is called from help-fns, so help-fns should be loaded at + ;; this point. + (declare-function help-fns-short-filename "help-fns" (filename)) + (let ((generic (if (symbolp function) (cl--generic function)))) + (when generic + (require 'help-mode) ;Needed for `help-function-def' button! + (save-excursion + (insert "\n\nThis is a generic function.\n\n") + (insert (propertize "Implementations:\n\n" 'face 'bold)) + ;; Loop over fanciful generics + (dolist (method (cl--generic-method-table generic)) + (let* ((info (cl--generic-method-info method))) + ;; FIXME: Add hyperlinks for the types as well. + (insert (format "%s%S" (nth 0 info) (nth 1 info))) + (let* ((met-name (cons function + (cl--generic-method-specializers method))) + (file (find-lisp-object-file-name met-name 'cl-defmethod))) + (when file + (insert (substitute-command-keys " in `")) + (help-insert-xref-button (help-fns-short-filename file) + 'help-function-def met-name file + 'cl-defmethod) + (insert (substitute-command-keys "'.\n")))) + (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) + +(defun cl--generic-specializers-apply-to-type-p (specializers type) + "Return non-nil if a method with SPECIALIZERS applies to TYPE." + (let ((applies nil)) + (dolist (specializer specializers) + (if (memq (car-safe specializer) '(subclass eieio--static)) + (setq specializer (nth 1 specializer))) + ;; Don't include the methods that are "too generic", such as those + ;; applying to `eieio-default-superclass'. + (and (not (memq specializer '(t eieio-default-superclass))) + (or (equal type specializer) + (when (symbolp specializer) + (let ((sclass (cl--find-class specializer)) + (tclass (cl--find-class type))) + (when (and sclass tclass) + (member specializer (cl--generic-class-parents tclass)))))) + (setq applies t))) + applies)) + +(defun cl--generic-all-functions (&optional type) + "Return a list of all generic functions. +Optional TYPE argument returns only those functions that contain +methods for TYPE." + (let ((l nil)) + (mapatoms + (lambda (symbol) + (let ((generic (and (fboundp symbol) (cl--generic symbol)))) + (and generic + (catch 'found + (if (null type) (throw 'found t)) + (dolist (method (cl--generic-method-table generic)) + (if (cl--generic-specializers-apply-to-type-p + (cl--generic-method-specializers method) type) + (throw 'found t)))) + (push symbol l))))) + l)) + +(defun cl--generic-method-documentation (function type) + "Return info for all methods of FUNCTION (a symbol) applicable to TYPE. +The value returned is a list of elements of the form +\(QUALIFIERS ARGS DOC)." + (let ((generic (cl--generic function)) + (docs ())) + (when generic + (dolist (method (cl--generic-method-table generic)) + (when (cl--generic-specializers-apply-to-type-p + (cl--generic-method-specializers method) type) + (push (cl--generic-method-info method) docs)))) + docs)) + +;;; Support for (head <val>) specializers. + +;; For both the `eql' and the `head' specializers, the dispatch +;; is unsatisfactory. Basically, in the "common&fast case", we end up doing +;; +;; (let ((tag (gethash value <tagcode-hashtable>))) +;; (funcall (gethash tag <method-cache>))) +;; +;; whereas we'd like to just do +;; +;; (funcall (gethash value <method-cache>))) +;; +;; but the problem is that the method-cache is normally "open ended", so +;; a nil means "not computed yet" and if we bump into it, we dutifully fill the +;; corresponding entry, whereas we'd want to just fallback on some default +;; effective method (so as not to fill the cache with lots of redundant +;; entries). + +(defvar cl--generic-head-used (make-hash-table :test #'eql)) + +(cl-generic-define-generalizer cl--generic-head-generalizer + 80 (lambda (name &rest _) `(gethash (car-safe ,name) cl--generic-head-used)) + (lambda (tag &rest _) (if (eq (car-safe tag) 'head) (list tag)))) + +(cl-defmethod cl-generic-generalizers :extra "head" (specializer) + "Support for the `(head VAL)' specializers." + ;; We have to implement `head' here using the :extra qualifier, + ;; since we can't use the `head' specializer to implement itself. + (if (not (eq (car-safe specializer) 'head)) + (cl-call-next-method) + (cl--generic-with-memoization + (gethash (cadr specializer) cl--generic-head-used) specializer) + (list cl--generic-head-generalizer))) + +(cl--generic-prefill-dispatchers 0 (head eql)) + +;;; Support for (eql <val>) specializers. + +(defvar cl--generic-eql-used (make-hash-table :test #'eql)) + +(cl-generic-define-generalizer cl--generic-eql-generalizer + 100 (lambda (name &rest _) `(gethash ,name cl--generic-eql-used)) + (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag)))) + +(cl-defmethod cl-generic-generalizers ((specializer (head eql))) + "Support for the `(eql VAL)' specializers." + (puthash (cadr specializer) specializer cl--generic-eql-used) + (list cl--generic-eql-generalizer)) + +(cl--generic-prefill-dispatchers 0 (eql nil)) +(cl--generic-prefill-dispatchers window-system (eql nil)) + +;;; Support for cl-defstructs specializers. + +(defun cl--generic-struct-tag (name &rest _) + ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) + ;; but that would suffer from some problems: + ;; - the vector may have size 0. + ;; - when called on an actual vector (rather than an object), we'd + ;; end up returning an arbitrary value, possibly colliding with + ;; other tagcode's values. + ;; - it can also result in returning all kinds of irrelevant + ;; values which would end up filling up the method-cache with + ;; lots of irrelevant/redundant entries. + ;; FIXME: We could speed this up by introducing a dedicated + ;; vector type at the C level, so we could do something like + ;; (and (vector-objectp ,name) (aref ,name 0)) + `(and (vectorp ,name) + (> (length ,name) 0) + (let ((tag (aref ,name 0))) + (and (symbolp tag) + (eq (symbol-function tag) :quick-object-witness-check) + tag)))) + +(defun cl--generic-class-parents (class) + (let ((parents ()) + (classes (list class))) + ;; BFS precedence. FIXME: Use a topological sort. + (while (let ((class (pop classes))) + (cl-pushnew (cl--class-name class) parents) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse parents))) + +(defun cl--generic-struct-specializers (tag &rest _) + (and (symbolp tag) (boundp tag) + (let ((class (symbol-value tag))) + (when (cl-typep class 'cl-structure-class) + (cl--generic-class-parents class))))) + +(cl-generic-define-generalizer cl--generic-struct-generalizer + 50 #'cl--generic-struct-tag + #'cl--generic-struct-specializers) + +(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type) + "Support for dispatch on cl-struct types." + (or + (when (symbolp type) + ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than + ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can + ;; take place without requiring cl-lib. + (let ((class (cl--find-class type))) + (and (cl-typep class 'cl-structure-class) + (or (null (cl--struct-class-type class)) + (error "Can't dispatch on cl-struct %S: type is %S" + type (cl--struct-class-type class))) + (progn (cl-assert (null (cl--struct-class-named class))) t) + (list cl--generic-struct-generalizer)))) + (cl-call-next-method))) + +(cl--generic-prefill-dispatchers 0 cl--generic-generalizer) + +;;; Dispatch on "system types". + +(defconst cl--generic-typeof-types + ;; Hand made from the source code of `type-of'. + '((integer number) (symbol) (string array sequence) (cons list sequence) + ;; Markers aren't `numberp', yet they are accepted wherever integers are + ;; accepted, pretty much. + (marker) (overlay) (float number) (window-configuration) + (process) (window) (subr) (compiled-function) (buffer) + (char-table array sequence) + (bool-vector array sequence) + (frame) (hash-table) (font-spec) (font-entity) (font-object) + (vector array sequence) + ;; Plus, hand made: + (null symbol list sequence) + (list sequence) + (array sequence) + (sequence) + (number))) + +(cl-generic-define-generalizer cl--generic-typeof-generalizer + ;; FIXME: We could also change `type-of' to return `null' for nil. + 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null)) + (lambda (tag &rest _) + (and (symbolp tag) (assq tag cl--generic-typeof-types)))) + +(cl-defmethod cl-generic-generalizers :extra "typeof" (type) + "Support for dispatch on builtin types." + ;; FIXME: Add support for other types accepted by `cl-typep' such + ;; as `character', `atom', `face', `function', ... + (or + (and (assq type cl--generic-typeof-types) + (progn + ;; FIXME: While this wrinkle in the semantics can be occasionally + ;; problematic, this warning is more often annoying than helpful. + ;;(if (memq type '(vector array sequence)) + ;; (message "`%S' also matches CL structs and EIEIO classes" + ;; type)) + (list cl--generic-typeof-generalizer))) + (cl-call-next-method))) + +(cl--generic-prefill-dispatchers 0 integer) + +;;; Dispatch on major mode. + +;; Two parts: +;; - first define a specializer (derived-mode <mode>) to match symbols +;; representing major modes, while obeying the major mode hierarchy. +;; - then define a context-rewriter so you can write +;; "&context (major-mode c-mode)" rather than +;; "&context (major-mode (derived-mode c-mode))". + +(defun cl--generic-derived-specializers (mode &rest _) + ;; FIXME: Handle (derived-mode <mode1> ... <modeN>) + (let ((specializers ())) + (while mode + (push `(derived-mode ,mode) specializers) + (setq mode (get mode 'derived-mode-parent))) + (nreverse specializers))) + +(cl-generic-define-generalizer cl--generic-derived-generalizer + 90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name)) + #'cl--generic-derived-specializers) + +(cl-defmethod cl-generic-generalizers ((_specializer (head derived-mode))) + "Support for the `(derived-mode MODE)' specializers." + (list cl--generic-derived-generalizer)) + +(cl-generic-define-context-rewriter major-mode (mode &rest modes) + `(major-mode ,(if (consp mode) + ;;E.g. could be (eql ...) + (progn (cl-assert (null modes)) mode) + `(derived-mode ,mode . ,modes)))) + +;; Local variables: +;; generated-autoload-file: "cl-loaddefs.el" +;; End: + +(provide 'cl-generic) +;;; cl-generic.el ends here diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index bbfe9ec6424..5134e50fa3b 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-2015 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 @@ -27,6 +27,8 @@ ;; This package supplies a single entry point, common-lisp-indent-function, ;; which performs indentation in the preferred style for Common Lisp code. +;; It is also a suitable function for indenting Emacs lisp code. +;; ;; To enable it: ;; ;; (setq lisp-indent-function 'common-lisp-indent-function) @@ -136,6 +138,19 @@ If non-nil, alignment is done with the first parameter :type 'boolean :group 'lisp-indent) +(defcustom lisp-indent-backquote-substitution-mode t + "How to indent substitutions in backquotes. +If t, the default, indent substituted forms normally. +If nil, do not apply special indentation rule to substituted +forms. If `corrected', subtract the `,' or `,@' from the form +column, indenting as if this character sequence were not present. +In any case, do not backtrack beyond a backquote substitution. + +Until Emacs 25.1, the nil behavior was hard-wired." + :version "25.1" + :type '(choice (const corrected) (const nil) (const t)) + :group 'lisp-indent) + (defvar lisp-indent-defun-method '(4 &lambda &body) "Defun-like indentation method. @@ -143,7 +158,7 @@ This applies when the value of the `common-lisp-indent-function' property is set to `defun'.") -(defun extended-loop-p (loop-start) +(defun lisp-extended-loop-p (loop-start) "True if an extended loop form starts at LOOP-START." (condition-case () (save-excursion @@ -154,16 +169,36 @@ is set to `defun'.") (looking-at "\\sw")) (error t))) +(defun lisp-indent-find-method (symbol &optional no-compat) + "Find the lisp indentation function for SYMBOL. +If NO-COMPAT is non-nil, do not retrieve indenters intended for +the standard lisp indent package." + (or (and (derived-mode-p 'emacs-lisp-mode) + (get symbol 'common-lisp-indent-function-for-elisp)) + (get symbol 'common-lisp-indent-function) + (and (not no-compat) + (get symbol 'lisp-indent-function)))) (defun common-lisp-loop-part-indentation (indent-point state) "Compute the indentation of loop form constituents." (let* ((loop-indentation (save-excursion (goto-char (elt state 1)) - (current-column)))) + (current-column)))) + (when (and (eq lisp-indent-backquote-substitution-mode 'corrected)) + (save-excursion + (goto-char (elt state 1)) + (incf loop-indentation + (cond ((eq (char-before) ?,) -1) + ((and (eq (char-before) ?@) + (progn (backward-char) + (eq (char-before) ?,))) + -2) + (t 0))))) + (goto-char indent-point) (beginning-of-line) (list - (cond ((not (extended-loop-p (elt state 1))) + (cond ((not (lisp-extended-loop-p (elt state 1))) (+ loop-indentation lisp-simple-loop-indentation)) ((looking-at "^\\s-*\\(:?\\sw+\\|;\\)") (+ loop-indentation lisp-loop-keyword-indentation)) @@ -245,9 +280,23 @@ For example, the function `case' has an indent property * indent the first argument by 4. * arguments after the first should be lists, and there may be any number of them. The first list element has an offset of 2, all the rest - have an offset of 2+1=3." + have an offset of 2+1=3. + +If the current mode is actually `emacs-lisp-mode', look for a +`common-lisp-indent-function-for-elisp' property before looking +at `common-lisp-indent-function' and, if set, use its value +instead." + ;; FIXME: why do we need to special-case loop? (if (save-excursion (goto-char (elt state 1)) - (looking-at "([Ll][Oo][Oo][Pp]")) + (and (looking-at (if (derived-mode-p 'emacs-lisp-mode) + "(\\(cl-\\)?loop" + "([Ll][Oo][Oo][Pp]")) + (or lisp-indent-backquote-substitution-mode + (not + (or (and (eq (char-before) ?@) + (progn (backward-char) + (eq (char-before) ?,))) + (eq (char-before) ?,)))))) (common-lisp-loop-part-indentation indent-point state) (common-lisp-indent-function-1 indent-point state))) @@ -291,18 +340,29 @@ For example, the function `case' has an indent property (setq function (downcase (buffer-substring-no-properties tem (point)))) (goto-char tem) + ;; Elisp generally provides CL functionality with a CL + ;; prefix, so if we have a special indenter for the + ;; unprefixed version, prefer it over whatever's defined + ;; for the cl- version. Users can override this + ;; heuristic by defining a + ;; common-lisp-indent-function-for-elisp property on the + ;; cl- version. + (when (and (derived-mode-p 'emacs-lisp-mode) + (not (lisp-indent-find-method + (intern-soft function) t)) + (string-match "\\`cl-" function) + (setf tem (intern-soft + (substring function (match-end 0)))) + (lisp-indent-find-method tem t)) + (setf function (symbol-name tem))) (setq tem (intern-soft function) - method (get tem 'common-lisp-indent-function)) - (cond ((and (null method) - (string-match ":[^:]+" function)) - ;; The pleblisp package feature - (setq function (substring function - (1+ (match-beginning 0))) - method (get (intern-soft function) - 'common-lisp-indent-function))) - ((and (null method)) - ;; backwards compatibility - (setq method (get tem 'lisp-indent-function))))) + method (lisp-indent-find-method tem)) + ;; The pleblisp package feature + (when (and (null tem) + (string-match ":[^:]+" function)) + (setq function (substring function (1+ (match-beginning 0))) + tem (intern-soft function) + method (lisp-indent-find-method tem)))) (let ((n 0)) ;; How far into the containing form is the current form? (if (< (point) indent-point) @@ -343,11 +403,21 @@ For example, the function `case' has an indent property (not (eq (char-after (- containing-sexp 2)) ?\#))) ;; No indentation for "'(...)" elements (setq calculated (1+ sexp-column))) - ((or (eq (char-after (1- containing-sexp)) ?\,) - (and (eq (char-after (1- containing-sexp)) ?\@) - (eq (char-after (- containing-sexp 2)) ?\,))) - ;; ",(...)" or ",@(...)" - (setq calculated normal-indent)) + ((when + (or (eq (char-after (1- containing-sexp)) ?\,) + (and (eq (char-after (1- containing-sexp)) ?\@) + (eq (char-after (- containing-sexp 2)) ?\,))) + ;; ",(...)" or ",@(...)" + (when (eq lisp-indent-backquote-substitution-mode + 'corrected) + (incf sexp-column -1) + (when (eq (char-after (1- containing-sexp)) ?\@) + (incf sexp-column -1))) + (cond (lisp-indent-backquote-substitution-mode + (setf tentative-calculated normal-indent) + (setq depth lisp-indent-maximum-backtracking) + nil) + (t (setq calculated normal-indent))))) ((eq (char-after (1- containing-sexp)) ?\#) ;; "#(...)" (setq calculated (1+ sexp-column))) @@ -756,6 +826,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))))) @@ -763,7 +834,12 @@ optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\ (put (car el) 'common-lisp-indent-function (if (symbolp (cdr el)) (get (cdr el) 'common-lisp-indent-function) - (car (cdr el)))))) + (car (cdr el)))))) + +;; In elisp, the else part of `if' is in an implicit progn, so indent +;; it more. +(put 'if 'common-lisp-indent-function-for-elisp 2) +(put 'with-output-to-string 'common-lisp-indent-function-for-elisp 0) ;(defun foo (x) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index e826cf4375a..2dd05192019 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-2015 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 1.0 @@ -152,9 +152,6 @@ an element already on the list. `(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))) - (defun cl--set-buffer-substring (start end val) (save-excursion (delete-region start end) (goto-char start) @@ -252,16 +249,6 @@ so that they are registered at compile-time as well as run-time." `(progn ,@body)))) ; Avoid loading cl-macs.el for cl-eval-when. -;;; Symbols. - -(defun cl--random-time () - (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) - (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) - v)) - -(defvar cl--gensym-counter (* (logand (cl--random-time) 1023) 100)) - - ;;; Numbers. (define-obsolete-function-alias 'cl-floatp-safe 'floatp "24.4") @@ -282,6 +269,30 @@ so that they are registered at compile-time as well as run-time." "Return t if INTEGER is even." (eq (logand integer 1) 0)) +(defconst cl-digit-char-table + (let* ((digits (make-vector 256 nil)) + (populate (lambda (start end base) + (mapc (lambda (i) + (aset digits i (+ base (- i start)))) + (number-sequence start end))))) + (funcall populate ?0 ?9 0) + (funcall populate ?A ?Z 10) + (funcall populate ?a ?z 10) + digits)) + +(defun cl-digit-char-p (char &optional radix) + "Test if CHAR is a digit in the specified RADIX (default 10). +If true return the decimal value of digit CHAR in RADIX." + (or (<= 2 (or radix 10) 36) + (signal 'args-out-of-range (list 'radix radix '(2 36)))) + (let ((n (aref cl-digit-char-table char))) + (and n (< n (or radix 10)) n))) + +(defun cl--random-time () + (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) + (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) + v)) + (defvar cl--random-state (vector 'cl--random-state-tag -1 30 (cl--random-time))) @@ -361,7 +372,13 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp (cl--defalias 'cl-first 'car) (cl--defalias 'cl-second 'cadr) (cl--defalias 'cl-rest 'cdr) -(cl--defalias 'cl-endp 'null) + +(defun cl-endp (x) + "Return true if X is the empty list; false if it is a cons. +Signal an error if X is not a list." + (if (listp x) + (null x) + (signal 'wrong-type-argument (list 'listp x 'x)))) (cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.") (cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.") @@ -398,122 +415,122 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp (defun cl-caaar (x) "Return the `car' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (car x)))) (defun cl-caadr (x) "Return the `car' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (cdr x)))) (defun cl-cadar (x) "Return the `car' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (car x)))) (defun cl-caddr (x) "Return the `car' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (cdr x)))) (defun cl-cdaar (x) "Return the `cdr' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (car x)))) (defun cl-cdadr (x) "Return the `cdr' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (cdr x)))) (defun cl-cddar (x) "Return the `cdr' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (car x)))) (defun cl-cdddr (x) "Return the `cdr' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (cdr x)))) (defun cl-caaaar (x) "Return the `car' of the `car' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (car (car x))))) (defun cl-caaadr (x) "Return the `car' of the `car' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (car (cdr x))))) (defun cl-caadar (x) "Return the `car' of the `car' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (cdr (car x))))) (defun cl-caaddr (x) "Return the `car' of the `car' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (cdr (cdr x))))) (defun cl-cadaar (x) "Return the `car' of the `cdr' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (car (car x))))) (defun cl-cadadr (x) "Return the `car' of the `cdr' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (car (cdr x))))) (defun cl-caddar (x) "Return the `car' of the `cdr' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (cdr (car x))))) (defun cl-cadddr (x) "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (cdr (cdr x))))) (defun cl-cdaaar (x) "Return the `cdr' of the `car' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (car (car x))))) (defun cl-cdaadr (x) "Return the `cdr' of the `car' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (car (cdr x))))) (defun cl-cdadar (x) "Return the `cdr' of the `car' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (cdr (car x))))) (defun cl-cdaddr (x) "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (cdr (cdr x))))) (defun cl-cddaar (x) "Return the `cdr' of the `cdr' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (car (car x))))) (defun cl-cddadr (x) "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (car (cdr x))))) (defun cl-cdddar (x) "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (cdr (car x))))) (defun cl-cddddr (x) "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (cdr (cdr x))))) ;;(defun last* (x &optional n) @@ -607,7 +624,6 @@ the process stops as soon as KEYS or VALUES run out. If ALIST is non-nil, the new pairs are prepended to it." (nconc (cl-mapcar 'cons keys values) alist)) - ;;; Generalized variables. ;; These used to be in cl-macs.el since all macros that use them (like setf) @@ -625,7 +641,6 @@ If ALIST is non-nil, the new pairs are prepended to it." `(insert (prog1 ,store (erase-buffer)))) (gv-define-simple-setter buffer-substring cl--set-buffer-substring) (gv-define-simple-setter current-buffer set-buffer) -(gv-define-simple-setter current-case-table set-case-table) (gv-define-simple-setter current-column move-to-column t) (gv-define-simple-setter current-global-map use-global-map t) (gv-define-setter current-input-mode (store) @@ -680,7 +695,6 @@ If ALIST is non-nil, the new pairs are prepended to it." (gv-define-setter window-width (store) `(progn (enlarge-window (- ,store (window-width)) t) ,store)) (gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) -(gv-define-simple-setter x-get-selection x-own-selection t) ;; More complex setf-methods. @@ -703,35 +717,19 @@ If ALIST is non-nil, the new pairs are prepended to it." (gv-define-expander substring (lambda (do place from &optional to) (gv-letplace (getter setter) place - (macroexp-let2 nil start from - (macroexp-let2 nil end to - (funcall do `(substring ,getter ,start ,end) - (lambda (v) - (funcall setter `(cl--set-substring - ,getter ,start ,end ,v))))))))) + (macroexp-let2* nil ((start from) (end to)) + (funcall do `(substring ,getter ,start ,end) + (lambda (v) + (funcall setter `(cl--set-substring + ,getter ,start ,end ,v)))))))) ;;; Miscellaneous. -;;;###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. - (autoload 'cl--defsubst-expand "cl-macs") - ;; Autoload, so autoload.el and font-lock can use it even when CL - ;; is not loaded. - (put 'cl-defun 'doc-string-elt 3) - (put 'cl-defmacro 'doc-string-elt 3) - (put 'cl-defsubst 'doc-string-elt 3) - (put 'cl-defstruct 'doc-string-elt 2)) - (provide 'cl-lib) -(or (load "cl-loaddefs" 'noerror 'quiet) - ;; When bootstrapping, cl-loaddefs hasn't been built yet! - (require 'cl-macs)) +(unless (load "cl-loaddefs" 'noerror 'quiet) + ;; When bootstrapping, cl-loaddefs hasn't been built yet! + (require 'cl-macs) + (require 'cl-seq)) ;; Local variables: ;; byte-compile-dynamic: t diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index d9d6658811f..c42094f0f0c 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,6 +1,6 @@ -;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t; coding: utf-8 -*- +;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2015 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Old-Version: 2.02 @@ -70,20 +70,12 @@ (setq form `(cons ,(car args) ,form))) form)) +;; Note: `cl--compiler-macro-cXXr' has been copied to +;; `internal--compiler-macro-cXXr' in subr.el. If you amend either +;; one, you may want to amend the other, too. ;;;###autoload -(defun cl--compiler-macro-cXXr (form x) - (let* ((head (car form)) - (n (symbol-name (car form))) - (i (- (length n) 2))) - (if (not (string-match "c[ad]+r\\'" n)) - (if (and (fboundp head) (symbolp (symbol-function head))) - (cl--compiler-macro-cXXr (cons (symbol-function head) (cdr form)) - x) - (error "Compiler macro for cXXr applied to non-cXXr form")) - (while (> i (match-beginning 0)) - (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x)) - (setq i (1- i))) - x))) +(define-obsolete-function-alias 'cl--compiler-macro-cXXr + 'internal--compiler-macro-cXXr "25.1") ;;; Some predicates for analyzing Lisp forms. ;; These are used by various @@ -135,7 +127,13 @@ (t t))) (defun cl--const-expr-val (x) - (and (macroexp-const-p x) (if (consp x) (nth 1 x) x))) + "Return the value of X known at compile-time. +If X is not known at compile time, return nil. Before testing +whether X is known at compile time, macroexpand it completely in +`macroexpand-all-environment'." + (let ((x (macroexpand-all x macroexpand-all-environment))) + (if (macroexp-const-p x) + (if (consp x) (nth 1 x) x)))) (defun cl--expr-contains (x y) "Count number of times X refers to Y. Return nil for 0 times." @@ -163,7 +161,7 @@ ;;; Symbols. -(defvar cl--gensym-counter) +(defvar cl--gensym-counter 0) ;;;###autoload (defun cl-gensym (&optional prefix) "Generate a new uninterned symbol. @@ -209,11 +207,26 @@ 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)) -(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) -(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms) +;; Internal hacks used in formal arg lists: +;; - &cl-quote: Added to formal-arglists to mean that any default value +;; mentioned in the formal arglist should be considered as implicitly +;; quoted rather than evaluated. This is used in `cl-defsubst' when +;; performing compiler-macro-expansion, since at that time the +;; arguments hold expressions rather than values. +;; - &cl-defs (DEF . DEFS): Gives the default value to use for missing +;; optional arguments which don't have an explicit default value. +;; DEFS is an alist mapping vars to their default default value. +;; and DEF is the default default to use for all other vars. + +(defvar cl--bind-block) ;Name of surrounding block, only use for `signal' data. +(defvar cl--bind-defs) ;(DEF . DEFS) giving the "default default" for optargs. +(defvar cl--bind-enquote) ;Non-nil if &cl-quote was in the formal arglist! +(defvar cl--bind-lets) (defvar cl--bind-forms) (defun cl--transform-lambda (form bind-block) "Transform a function form FORM of name BIND-BLOCK. @@ -223,57 +236,88 @@ function's body. FORM is of the form (ARGS . BODY)." (let* ((args (car form)) (body (cdr form)) (orig-args args) (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) - (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) - (header nil) (simple-args nil)) - (while (or (stringp (car body)) - (memq (car-safe (car body)) '(interactive declare cl-declare))) - (push (pop body) header)) + (parsed-body (macroexp-parse-body body)) + (header (car parsed-body)) (simple-args nil)) + (setq body (cdr parsed-body)) + ;; "(. X) to (&rest X)" conversion already done in cl--do-arglist, but we + ;; do it here as well, so as to be able to see if we can avoid + ;; cl--do-arglist. (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq cl--bind-defs args)) - cl--bind-defs (cadr cl--bind-defs))) + (let ((cl-defs (memq '&cl-defs args))) + (when cl-defs + (setq cl--bind-defs (cadr cl-defs)) + ;; Remove "&cl-defs DEFS" from args. + (setcdr cl-defs (cddr cl-defs)) + (setq args (delq '&cl-defs args)))) (if (setq cl--bind-enquote (memq '&cl-quote args)) (setq args (delq '&cl-quote args))) (if (memq '&whole args) (error "&whole not currently implemented")) - (let* ((p (memq '&environment args)) (v (cadr p)) - (env-exp 'macroexpand-all-environment)) + (let* ((p (memq '&environment args)) + (v (cadr p))) (if p (setq args (nconc (delq (car p) (delq v args)) - (list '&aux (list v env-exp)))))) - (while (and args (symbolp (car args)) - (not (memq (car args) '(nil &rest &body &key &aux))) - (not (and (eq (car args) '&optional) - (or cl--bind-defs (consp (cadr args)))))) - (push (pop args) simple-args)) + `(&aux (,v macroexpand-all-environment)))))) + ;; Take away all the simple args whose parsing can be handled more + ;; efficiently by a plain old `lambda' than the manual parsing generated + ;; by `cl--do-arglist'. + (let ((optional nil)) + (while (and args (symbolp (car args)) + (not (memq (car args) '(nil &rest &body &key &aux))) + (or (not optional) + ;; Optional args whose default is nil are simple. + (null (nth 1 (assq (car args) (cdr cl--bind-defs))))) + (not (and (eq (car args) '&optional) (setq optional t) + (car cl--bind-defs)))) + (push (pop args) simple-args)) + (when optional + (if args (push '&optional args)) + ;; Don't keep a dummy trailing &optional without actual optional args. + (if (eq '&optional (car simple-args)) (pop simple-args)))) (or (eq cl--bind-block 'cl-none) (setq body (list `(cl-block ,cl--bind-block ,@body)))) - (if (null args) - (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) - (if (memq '&optional simple-args) (push '&optional args)) - (cl--do-arglist args nil (- (length simple-args) - (if (memq '&optional simple-args) 1 0))) - (setq cl--bind-lets (nreverse cl--bind-lets)) - (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) - ,@(nreverse cl--bind-inits))) - (nconc (nreverse simple-args) - (list '&rest (car (pop cl--bind-lets)))) - (nconc (let ((hdr (nreverse header))) + (let* ((cl--bind-lets nil) (cl--bind-forms nil) + (rest-args + (cond + ((null args) nil) + ((eq (car args) '&aux) + (cl--do-&aux args) + (setq cl--bind-lets (nreverse cl--bind-lets)) + nil) + (t ;; `simple-args' doesn't handle all the parsing that we need, + ;; so we pass the rest to cl--do-arglist which will do + ;; "manual" parsing. + (let ((slen (length simple-args))) + (when (memq '&optional simple-args) + (cl-decf slen)) + (setq header ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not ;; touch the match-data. (save-match-data - (require 'help-fns) (cons (help-add-fundoc-usage - (if (stringp (car hdr)) (pop hdr)) + (if (stringp (car header)) (pop header)) ;; Be careful with make-symbol and (back)quote, ;; see bug#12884. (let ((print-gensym nil) (print-quoted t)) (format "%S" (cons 'fn (cl--make-usage-args orig-args))))) - hdr))) - (list `(let* ,cl--bind-lets - ,@(nreverse cl--bind-forms) - ,@body))))))) + header))) + ;; FIXME: we'd want to choose an arg name for the &rest param + ;; and pass that as `expr' to cl--do-arglist, but that ends up + ;; generating code with a redundant let-binding, so we instead + ;; pass a dummy and then look in cl--bind-lets to find what var + ;; this was bound to. + (cl--do-arglist args :dummy slen) + (setq cl--bind-lets (nreverse cl--bind-lets)) + ;; (cl-assert (eq :dummy (nth 1 (car cl--bind-lets)))) + (list '&rest (car (pop cl--bind-lets)))))))) + `(nil + (,@(nreverse simple-args) ,@rest-args) + ,@header + ,(macroexp-let* cl--bind-lets + (macroexp-progn + `(,@(nreverse cl--bind-forms) + ,@body))))))) ;;;###autoload (defmacro cl-defun (name args &rest body) @@ -295,6 +339,27 @@ and BODY is implicitly surrounded by (cl-block NAME ...). (form `(defun ,name ,@(cdr res)))) (if (car res) `(progn ,(car res) ,form) form))) +;;;###autoload +(defmacro cl-iter-defun (name args &rest body) + "Define NAME as a generator function. +Like normal `iter-defun', except ARGLIST allows full Common Lisp conventions, +and BODY is implicitly surrounded by (cl-block NAME ...). + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug + ;; Same as iter-defun but use cl-lambda-list. + (&define [&or name ("setf" :name setf name)] + cl-lambda-list + cl-declarations-or-string + [&optional ("interactive" interactive)] + def-body)) + (doc-string 3) + (indent 2)) + (require 'generator) + (let* ((res (cl--transform-lambda (cons args body) name)) + (form `(iter-defun ,name ,@(cdr res)))) + (if (car res) `(progn ,(car res) ,form) form))) + ;; The lambda list for macros is different from that of normal lambdas. ;; Note that &environment is only allowed as first or last items in the ;; top level list. @@ -374,8 +439,6 @@ its argument list allows full Common Lisp conventions." (if (car res) `(progn ,(car res) ,form) form)) `(function ,func))) -(declare-function help-add-fundoc-usage "help-fns" (docstring arglist)) - (defun cl--make-usage-var (x) "X can be a var or a (destructuring) lambda-list." (cond @@ -384,6 +447,11 @@ its argument list allows full Common Lisp conventions." (t x))) (defun cl--make-usage-args (arglist) + (let ((aux (ignore-errors (cl-position '&aux arglist)))) + (when aux + ;; `&aux' args aren't arguments, so let's just drop them from the + ;; usage info. + (setq arglist (cl-subseq arglist 0 aux)))) (if (cdr-safe (last arglist)) ;Not a proper list. (let* ((last (last arglist)) (tail (cdr last))) @@ -392,8 +460,7 @@ its argument list allows full Common Lisp conventions." (setcdr last nil) (nconc (cl--make-usage-args arglist) (cl--make-usage-var tail))) (setcdr last tail))) - ;; `orig-args' can contain &cl-defs (an internal - ;; CL thingy I don't understand), so remove it. + ;; `orig-args' can contain &cl-defs. (let ((x (memq '&cl-defs arglist))) (when x (setq arglist (delq (car x) (remq (cadr x) arglist))))) (let ((state nil)) @@ -420,7 +487,18 @@ its argument list allows full Common Lisp conventions." )))) arglist)))) -(defun cl--do-arglist (args expr &optional num) ; uses bind-* +(defun cl--do-&aux (args) + (while (and (eq (car args) '&aux) (pop args)) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) + (if (consp (car args)) + (if (and cl--bind-enquote (cl-cadar args)) + (cl--do-arglist (caar args) + `',(cadr (pop args))) + (cl--do-arglist (caar args) (cadr (pop args)))) + (cl--do-arglist (pop args) nil)))) + (if args (error "Malformed argument list ends with: %S" args))) + +(defun cl--do-arglist (args expr &optional num) ; uses cl--bind-* (if (nlistp args) (if (or (memq args cl--lambda-list-keywords) (not (symbolp args))) (error "Invalid argument name: %s" args) @@ -429,15 +507,14 @@ its argument list allows full Common Lisp conventions." (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) (let ((p (memq '&body args))) (if p (setcar p '&rest))) (if (memq '&environment args) (error "&environment used incorrectly")) - (let ((save-args args) - (restarg (memq '&rest args)) + (let ((restarg (memq '&rest args)) (safety (if (cl--compiling-file) cl--optimize-safety 3)) (keys nil) (laterarg nil) (exactarg nil) minarg) (or num (setq num 0)) - (if (listp (cadr restarg)) - (setq restarg (make-symbol "--cl-rest--")) - (setq restarg (cadr restarg))) + (setq restarg (if (listp (cadr restarg)) + (make-symbol "--cl-rest--") + (cadr restarg))) (push (list restarg expr) cl--bind-lets) (if (eq (car args) '&whole) (push (list (cl--pop2 args) restarg) cl--bind-lets)) @@ -500,8 +577,13 @@ its argument list allows full Common Lisp conventions." (intern (format ":%s" name))))) (varg (if (consp (car arg)) (cl-cadar arg) (car arg))) (def (if (cdr arg) (cadr arg) - (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs))))) - (look `(memq ',karg ,restarg))) + ;; The ordering between those two or clauses is + ;; irrelevant, since in practice only one of the two + ;; is ever non-nil (the car is only used for + ;; cl-deftype which doesn't use the cdr). + (or (car cl--bind-defs) + (cadr (assq varg cl--bind-defs))))) + (look `(plist-member ,restarg ',karg))) (and def cl--bind-enquote (setq def `',def)) (if (cddr arg) (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--"))) @@ -537,15 +619,8 @@ its argument list allows full Common Lisp conventions." keys) (car ,var))))))) (push `(let ((,var ,restarg)) ,check) cl--bind-forms))) - (while (and (eq (car args) '&aux) (pop args)) - (while (and args (not (memq (car args) cl--lambda-list-keywords))) - (if (consp (car args)) - (if (and cl--bind-enquote (cl-cadar args)) - (cl--do-arglist (caar args) - `',(cadr (pop args))) - (cl--do-arglist (caar args) (cadr (pop args)))) - (cl--do-arglist (pop args) nil)))) - (if args (error "Malformed argument list %s" save-args))))) + (cl--do-&aux args) + nil))) (defun cl--arglist-args (args) (if (nlistp args) (list args) @@ -564,12 +639,11 @@ its argument list allows full Common Lisp conventions." "Bind the variables in ARGS to the result of EXPR and execute BODY." (declare (indent 2) (debug (&define cl-macro-list def-form cl-declarations def-body))) - (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-inits nil) + (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil)) (cl--do-arglist (or args '(&aux)) expr) - (append '(progn) cl--bind-inits - (list `(let* ,(nreverse cl--bind-lets) - ,@(nreverse cl--bind-forms) ,@body))))) + (macroexp-let* (nreverse cl--bind-lets) + (macroexp-progn (append (nreverse cl--bind-forms) body))))) ;;; The `cl-eval-when' form. @@ -619,14 +693,20 @@ The result of the body appears to the compiler as a quoted constant." (set `(setq ,temp ,form))) (if (and (fboundp 'byte-compile-file-form-defmumble) (boundp 'this-kind) (boundp 'that-one)) - (fset 'byte-compile-file-form - `(lambda (form) - (fset 'byte-compile-file-form - ',(symbol-function 'byte-compile-file-form)) - (byte-compile-file-form ',set) - (byte-compile-file-form form))) - (print set (symbol-value 'byte-compile--outbuffer))) - `(symbol-value ',temp)) + ;; Else, we can't output right away, so we have to delay it to the + ;; next time we're at the top-level. + ;; FIXME: Use advice-add/remove. + (fset 'byte-compile-file-form + (let ((old (symbol-function 'byte-compile-file-form))) + (lambda (form) + (fset 'byte-compile-file-form old) + (byte-compile-file-form set) + (byte-compile-file-form form)))) + ;; If we're not in the middle of compiling something, we can + ;; output directly to byte-compile-outbuffer, to make sure + ;; temp is set before we use it. + (print set byte-compile--outbuffer)) + temp) `',(eval form))) @@ -643,30 +723,26 @@ allowed only in the final clause, and matches if no other keys match. Key values are compared by `eql'. \n(fn EXPR (KEYLIST BODY...)...)" (declare (indent 1) (debug (form &rest (sexp body)))) - (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) - (head-list nil) - (body (cons - 'cond - (mapcar - (function - (lambda (c) - (cons (cond ((memq (car c) '(t otherwise)) t) - ((eq (car c) 'cl--ecase-error-flag) - `(error "cl-ecase failed: %s, %s" - ,temp ',(reverse head-list))) - ((listp (car c)) - (setq head-list (append (car c) head-list)) - `(cl-member ,temp ',(car c))) - (t - (if (memq (car c) head-list) - (error "Duplicate key in case: %s" - (car c))) - (push (car c) head-list) - `(eql ,temp ',(car c)))) - (or (cdr c) '(nil))))) - clauses)))) - (if (eq temp expr) body - `(let ((,temp ,expr)) ,body)))) + (macroexp-let2 macroexp-copyable-p temp expr + (let* ((head-list nil)) + `(cond + ,@(mapcar + (lambda (c) + (cons (cond ((memq (car c) '(t otherwise)) t) + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-ecase failed: %s, %s" + ,temp ',(reverse head-list))) + ((listp (car c)) + (setq head-list (append (car c) head-list)) + `(cl-member ,temp ',(car c))) + (t + (if (memq (car c) head-list) + (error "Duplicate key in case: %s" + (car c))) + (push (car c) head-list) + `(eql ,temp ',(car c)))) + (or (cdr c) '(nil)))) + clauses))))) ;;;###autoload (defmacro cl-ecase (expr &rest clauses) @@ -686,24 +762,22 @@ final clause, and matches if no other keys match. \n(fn EXPR (TYPE BODY...)...)" (declare (indent 1) (debug (form &rest ([&or cl-type-spec "otherwise"] body)))) - (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) - (type-list nil) - (body (cons - 'cond - (mapcar - (function - (lambda (c) - (cons (cond ((eq (car c) 'otherwise) t) - ((eq (car c) 'cl--ecase-error-flag) - `(error "cl-etypecase failed: %s, %s" - ,temp ',(reverse type-list))) - (t - (push (car c) type-list) - (cl--make-type-test temp (car c)))) - (or (cdr c) '(nil))))) - clauses)))) - (if (eq temp expr) body - `(let ((,temp ,expr)) ,body)))) + (macroexp-let2 macroexp-copyable-p temp expr + (let* ((type-list nil)) + (cons + 'cond + (mapcar + (function + (lambda (c) + (cons (cond ((eq (car c) 'otherwise) t) + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-etypecase failed: %s, %s" + ,temp ',(reverse type-list))) + (t + (push (car c) type-list) + `(cl-typep ,temp ',(car c)))) + (or (cdr c) '(nil))))) + clauses))))) ;;;###autoload (defmacro cl-etypecase (expr &rest clauses) @@ -754,14 +828,22 @@ 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. @@ -808,20 +890,43 @@ For more details, see Info node `(cl)Loop Facility'. "repeat" "while" "until" "always" "never" "thereis" "collect" "append" "nconc" "sum" "count" "maximize" "minimize" "if" "unless" - "return"] form] + "return"] + form] ;; Simple default, which covers 99% of the cases. symbolp form))) (if (not (memq t (mapcar #'symbolp (delq nil (delq t (cl-copy-list loop-args)))))) `(cl-block nil (while t ,@loop-args)) (let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil) - (cl--loop-body nil) (cl--loop-steps nil) - (cl--loop-result nil) (cl--loop-result-explicit nil) - (cl--loop-result-var nil) (cl--loop-finish-flag nil) + (cl--loop-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)) @@ -837,15 +942,15 @@ For more details, see Info node `(cl)Loop Facility'. (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) @@ -1074,10 +1179,10 @@ For more details, see Info node `(cl)Loop Facility'. (if (memq (car cl--loop-args) '(downto above)) (error "Must specify `from' value for downward cl-loop")) (let* ((down (or (eq (car cl--loop-args) 'downfrom) - (memq (cl-caddr cl--loop-args) + (memq (nth 2 cl--loop-args) '(downto above)))) (excl (or (memq (car cl--loop-args) '(above below)) - (memq (cl-caddr cl--loop-args) + (memq (nth 2 cl--loop-args) '(above below)))) (start (and (memq (car cl--loop-args) '(from upfrom downfrom)) @@ -1100,7 +1205,8 @@ For more details, see Info node `(cl)Loop Facility'. (if end (push (list (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) cl--loop-body)) + var (or end-var end)) + cl--loop-body)) (push (list var (list (if down '- '+) var (or step-var step 1))) loop-for-steps))) @@ -1158,7 +1264,8 @@ For more details, see Info node `(cl)Loop Facility'. (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) (push `(< (setq ,temp-idx (1+ ,temp-idx)) - (length ,temp-vec)) cl--loop-body) + (length ,temp-vec)) + cl--loop-body) (if (eq word 'across-ref) (push (list var `(aref ,temp-vec ,temp-idx)) cl--loop-symbol-macs) @@ -1214,15 +1321,18 @@ For more details, see Info node `(cl)Loop Facility'. (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)) @@ -1232,11 +1342,12 @@ For more details, see Info node `(cl)Loop Facility'. ((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) @@ -1253,10 +1364,11 @@ For more details, see Info node `(cl)Loop Facility'. (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)) @@ -1272,10 +1384,11 @@ For more details, see Info node `(cl)Loop Facility'. (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--"))) @@ -1328,7 +1441,8 @@ For more details, see Info node `(cl)Loop Facility'. (if loop-for-sets (push `(progn ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) - t) cl--loop-body)) + t) + cl--loop-body)) (if loop-for-steps (push (cons (if ands 'cl-psetq 'setq) (apply 'append (nreverse loop-for-steps))) @@ -1346,7 +1460,8 @@ For more details, see Info node `(cl)Loop Facility'. (push `(progn (push ,what ,var) t) cl--loop-body) (push `(progn (setq ,var (nconc ,var (list ,what))) - t) cl--loop-body)))) + t) + cl--loop-body)))) ((memq word '(nconc nconcing append appending)) (let ((what (pop cl--loop-args)) @@ -1361,7 +1476,9 @@ For more details, see Info node `(cl)Loop Facility'. ,var) `(,(if (memq word '(nconc nconcing)) #'nconc #'append) - ,var ,what))) t) cl--loop-body))) + ,var ,what))) + t) + cl--loop-body))) ((memq word '(concat concating)) (let ((what (pop cl--loop-args)) @@ -1384,15 +1501,14 @@ For more details, see Info node `(cl)Loop Facility'. (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (pop cl--loop-args)) - (temp (if (cl--simple-expr-p what) what - (make-symbol "--cl-var--"))) - (var (cl--loop-handle-accum nil)) - (func (intern (substring (symbol-name word) 0 3))) - (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) - (push `(progn ,(if (eq temp what) set - `(let ((,temp ,what)) ,set)) - t) cl--loop-body))) + (push `(progn ,(macroexp-let2 macroexp-copyable-p temp + (pop cl--loop-args) + (let* ((var (cl--loop-handle-accum nil)) + (func (intern (substring (symbol-name word) + 0 3)))) + `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) + t) + cl--loop-body)) ((eq word 'with) (let ((bindings nil)) @@ -1446,12 +1562,9 @@ For more details, see Info node `(cl)Loop Facility'. (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)) @@ -1466,7 +1579,8 @@ For more details, see Info node `(cl)Loop Facility'. (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) (push `(setq ,cl--loop-result-var ,(pop cl--loop-args) - ,cl--loop-finish-flag nil) cl--loop-body)) + ,cl--loop-finish-flag nil) + cl--loop-body)) (t ;; This is an advertised interface: (info "(cl)Other Clauses"). @@ -1476,36 +1590,52 @@ For more details, see Info node `(cl)Loop Facility'. (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 (or (null temp) + (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. + (when (eq body 'setq) + (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))))) @@ -1613,7 +1743,7 @@ An implicit nil block is established around the loop. (declare (debug ((symbolp form &optional form) cl-declarations body)) (indent 1)) (let ((loop `(dolist ,spec ,@body))) - (if (advice-member-p #'cl--wrap-in-nil-block 'dolist) + (if (advice-member-p 'cl--wrap-in-nil-block 'dolist) loop `(cl-block nil ,loop)))) ;;;###autoload @@ -1626,7 +1756,7 @@ nil. \(fn (VAR COUNT [RESULT]) BODY...)" (declare (debug cl-dolist) (indent 1)) (let ((loop `(dotimes ,spec ,@body))) - (if (advice-member-p #'cl--wrap-in-nil-block 'dotimes) + (if (advice-member-p 'cl--wrap-in-nil-block 'dotimes) loop `(cl-block nil ,loop)))) (defvar cl--tagbody-alist nil) @@ -1656,7 +1786,8 @@ Labels have lexical scope and dynamic extent." (unless (eq 'go (car-safe (car-safe block))) (push `(go cl--exit) block)) (push (nreverse block) blocks)) - (let ((catch-tag (make-symbol "cl--tagbody-tag"))) + (let ((catch-tag (make-symbol "cl--tagbody-tag")) + (cl--tagbody-alist cl--tagbody-alist)) (push (cons 'cl--exit catch-tag) cl--tagbody-alist) (dolist (block blocks) (push (cons (car block) catch-tag) cl--tagbody-alist)) @@ -1689,7 +1820,7 @@ from OBARRAY. (let (,(car spec)) (mapatoms #'(lambda (,(car spec)) ,@body) ,@(and (cadr spec) (list (cadr spec)))) - ,(cl-caddr spec)))) + ,(nth 2 spec)))) ;;;###autoload (defmacro cl-do-all-symbols (spec &rest body) @@ -1737,6 +1868,8 @@ a `let' form, except that the list of symbols can be computed at run-time." (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) (eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun)))))))) +(defconst cl--labels-magic (make-symbol "cl--labels-magic")) + (defvar cl--labels-convert-cache nil) (defun cl--labels-convert (f) @@ -1748,10 +1881,12 @@ a `let' form, except that the list of symbols can be computed at run-time." ;; being expanded even though we don't receive it. ((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache)) (t - (let ((found (assq f macroexpand-all-environment))) - (if (and found (ignore-errors - (eq (cadr (cl-caddr found)) 'cl-labels-args))) - (cadr (cl-caddr (cl-cadddr found))) + (let* ((found (assq f macroexpand-all-environment)) + (replacement (and found + (ignore-errors + (funcall (cdr found) cl--labels-magic))))) + (if (and replacement (eq cl--labels-magic (car replacement))) + (nth 1 replacement) (let ((res `(function ,f))) (setq cl--labels-convert-cache (cons f res)) res)))))) @@ -1760,25 +1895,38 @@ a `let' form, except that the list of symbols can be computed at run-time." (defmacro cl-flet (bindings &rest body) "Make local function definitions. Like `cl-labels' but the definitions are not recursive. +Each binding can take the form (FUNC EXP) where +FUNC is the function name, and EXP is an expression that returns the +function value to which it should be bound, or it can take the more common +form \(FUNC ARGLIST BODY...) which is a shorthand +for (FUNC (lambda ARGLIST BODY)). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) - (let ((var (make-symbol (format "--cl-%s--" (car binding))))) - (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (let ((var (make-symbol (format "--cl-%s--" (car binding)))) + (args-and-body (cdr binding))) + (if (and (= (length args-and-body) 1) (symbolp (car args-and-body))) + ;; Optimize (cl-flet ((fun var)) body). + (setq var (car args-and-body)) + (push (list var (if (= (length args-and-body) 1) + (car args-and-body) + `(cl-function (lambda . ,args-and-body)))) + binds)) (push (cons (car binding) - `(lambda (&rest cl-labels-args) - (cl-list* 'funcall ',var - cl-labels-args))) + (lambda (&rest args) + (if (eq (car args) cl--labels-magic) + (list cl--labels-magic var) + `(funcall ,var ,@args)))) newenv))) - `(let ,(nreverse binds) - ,@(macroexp-unprogn - (macroexpand-all - `(progn ,@body) - ;; Don't override lexical-let's macro-expander. - (if (assq 'function newenv) newenv - (cons (cons 'function #'cl--labels-convert) newenv))))))) + ;; FIXME: Eliminate those functions which aren't referenced. + (macroexp-let* (nreverse binds) + (macroexpand-all + `(progn ,@body) + ;; Don't override lexical-let's macro-expander. + (if (assq 'function newenv) newenv + (cons (cons 'function #'cl--labels-convert) newenv)))))) ;;;###autoload (defmacro cl-flet* (bindings &rest body) @@ -1805,9 +1953,10 @@ in closures will only work if `lexical-binding' is in use. (let ((var (make-symbol (format "--cl-%s--" (car binding))))) (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) (push (cons (car binding) - `(lambda (&rest cl-labels-args) - (cl-list* 'funcall ',var - cl-labels-args))) + (lambda (&rest args) + (if (eq (car args) cl--labels-magic) + (list cl--labels-magic var) + (cl-list* 'funcall var args)))) newenv))) (macroexpand-all `(letrec ,(nreverse binds) ,@body) ;; Don't override lexical-let's macro-expander. @@ -1829,13 +1978,14 @@ This is like `cl-flet', but for macros instead of functions. cl-declarations body))) (if (cdr bindings) `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) - (if (null bindings) (cons 'progn body) + (if (null bindings) (macroexp-progn body) (let* ((name (caar bindings)) (res (cl--transform-lambda (cdar bindings) name))) (eval (car res)) - (macroexpand-all (cons 'progn body) - (cons (cons name `(lambda ,@(cdr res))) - macroexpand-all-environment)))))) + (macroexpand-all (macroexp-progn body) + (cons (cons name + (eval `(cl-function (lambda ,@(cdr res))) t)) + macroexpand-all-environment)))))) (defconst cl--old-macroexpand (if (and (boundp 'cl--old-macroexpand) @@ -1943,11 +2093,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-message "Malformed `cl-symbol-macrolet' binding: %S" + (car bindings)) + expansion) + expansion))) (fset 'macroexpand previous-macroexpand)))))) ;;; Multiple values. @@ -2001,10 +2158,18 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (declare (debug t)) (cons 'progn body)) ;;;###autoload -(defmacro cl-the (_type form) - "At present this ignores TYPE and is simply equivalent to FORM." +(defmacro cl-the (type form) + "Return FORM. If type-checking is enabled, assert that it is of TYPE." (declare (indent 1) (debug (cl-type-spec form))) - form) + (if (not (or (not (cl--compiling-file)) + (< cl--optimize-speed 3) + (= cl--optimize-safety 3))) + form + (macroexp-let2 macroexp-copyable-p temp form + `(progn (unless (cl-typep ,temp ',type) + (signal 'wrong-type-argument + (list ',type ,temp ',form))) + ,temp)))) (defvar cl--proclaim-history t) ; for future compilers (defvar cl--declare-stack t) ; for future compilers @@ -2261,8 +2426,80 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first. (if (symbolp func) (cons func rargs) `(funcall #',func ,@rargs)))))))) +;;;###autoload +(defmacro cl-defsubst (name args &rest body) + "Define NAME as a function. +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)) + (real-args (if (eq '&cl-defs (car args)) (cddr args) args)) + (p argns) + ;; (pbody (cons 'progn body)) + ) + (while (and p (eq (cl--expr-contains real-args (car p)) 1)) (pop p)) + `(progn + ,(if p nil ; give up if defaults refer to earlier args + `(cl-define-compiler-macro ,name + ,(if (memq '&key args) + `(&whole cl-whole &cl-quote ,@args) + (cons '&cl-quote args)) + (cl--defsubst-expand + ',argns '(cl-block ,name ,@body) + ;; We used to pass `simple' as + ;; (not (or unsafe (cl-expr-access-order pbody argns))) + ;; But this is much too simplistic since it + ;; does not pay attention to the argvs (and + ;; cl-expr-access-order itself is also too naive). + nil + ,(and (memq '&key args) 'cl-whole) nil ,@argns))) + (cl-defun ,name ,args ,@body)))) + +(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs) + (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole + (if (cl--simple-exprs-p argvs) (setq simple t)) + (let* ((substs ()) + (lets (delq nil + (cl-mapcar (lambda (argn argv) + (if (or simple (macroexp-const-p argv)) + (progn (push (cons argn argv) substs) + nil) + (list argn argv))) + argns argvs)))) + ;; FIXME: `sublis/subst' will happily substitute the symbol + ;; `argn' in places where it's not used as a reference + ;; to a variable. + ;; FIXME: `sublis/subst' will happily copy `argv' to a different + ;; scope, leading to name capture. + (setq body (cond ((null substs) body) + ((null (cdr substs)) + (cl-subst (cdar substs) (caar substs) body)) + (t (cl--sublis substs body)))) + (if lets `(let ,lets ,body) body)))) + +(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)))) + ;;; Structures. +(defmacro cl--find-class (type) + `(get ,type 'cl--class)) + +;; Rather than hard code cl-structure-object, we indirect through this variable +;; for bootstrapping reasons. +(defvar cl--struct-default-parent nil) + ;;;###autoload (defmacro cl-defstruct (struct &rest descs) "Define a struct type. @@ -2318,14 +2555,12 @@ non-nil value, that slot cannot be set via `setf'. (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) (include-descs nil) - (side-eff nil) + (include-name nil) (type nil) (named nil) (forms nil) + (docstring (if (stringp (car descs)) (pop descs))) pred-form pred-check) - (if (stringp (car descs)) - (push `(put ',name 'structure-documentation - ,(pop descs)) forms)) (setq descs (cons '(cl-tag-slot) (mapcar (function (lambda (x) (if (consp x) x (list x)))) descs))) @@ -2350,11 +2585,14 @@ non-nil value, that slot cannot be set via `setf'. ((eq opt :predicate) (if args (setq predicate (car args)))) ((eq opt :include) - (setq include (car args) - include-descs (mapcar (function - (lambda (x) - (if (consp x) x (list x)))) - (cdr args)))) + ;; FIXME: Actually, we can include more than once as long as + ;; we include EIEIO classes rather than cl-structs! + (when include-name (error "Can't :include more than once")) + (setq include-name (car args)) + (setq include-descs (mapcar (function + (lambda (x) + (if (consp x) x (list x)))) + (cdr args)))) ((eq opt :print-function) (setq print-func (car args))) ((eq opt :type) @@ -2366,19 +2604,21 @@ non-nil value, that slot cannot be set via `setf'. descs))) (t (error "Slot option %s unrecognized" opt))))) + (unless (or include-name type) + (setq include-name cl--struct-default-parent)) + (when include-name (setq include (cl--struct-get-class include-name))) (if print-func (setq print-func `(progn (funcall #',print-func cl-x cl-s cl-n) t)) - (or type (and include (not (get include 'cl-struct-print))) + (or type (and include (not (cl--struct-class-print include))) (setq print-auto t print-func (and (or (not (or include type)) (null print-func)) `(progn (princ ,(format "#S(%s" name) cl-s)))))) (if include - (let ((inc-type (get include 'cl-struct-type)) - (old-descs (get include 'cl-struct-slots))) - (or inc-type (error "%s is not a struct name" include)) - (and type (not (eq (car inc-type) type)) + (let* ((inc-type (cl--struct-class-type include)) + (old-descs (cl-struct-slot-info include))) + (and type (not (eq inc-type type)) (error ":type disagrees with :include for %s" name)) (while include-descs (setcar (memq (or (assq (caar include-descs) old-descs) @@ -2387,39 +2627,35 @@ non-nil value, that slot cannot be set via `setf'. old-descs) (pop include-descs))) (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) - type (car inc-type) - named (assq 'cl-tag-slot descs)) - (if (cadr inc-type) (setq tag name named t)) - (let ((incl include)) - (while incl - (push `(cl-pushnew ',tag - ,(intern (format "cl-struct-%s-tags" incl))) - forms) - (setq incl (get incl 'cl-struct-include))))) + type inc-type + named (if type (assq 'cl-tag-slot descs) 'true)) + (if (cl--struct-class-named include) (setq tag name named t))) (if type (progn (or (memq type '(vector list)) (error "Invalid :type specifier: %s" type)) (if named (setq tag name))) - (setq type 'vector named 'true))) + (setq named 'true))) (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) - (push `(defvar ,tag-symbol) forms) + (when (and (null predicate) named) + (setq predicate (intern (format "cl--struct-%s-p" name)))) (setq pred-form (and named (let ((pos (- (length descs) (length (memq (assq 'cl-tag-slot descs) descs))))) - (if (eq type 'vector) - `(and (vectorp cl-x) - (>= (length cl-x) ,(length descs)) - (memq (aref cl-x ,pos) ,tag-symbol)) - (if (= pos 0) - `(memq (car-safe cl-x) ,tag-symbol) - `(and (consp cl-x) + (cond + ((memq type '(nil vector)) + `(and (vectorp cl-x) + (>= (length cl-x) ,(length descs)) + (memq (aref cl-x ,pos) ,tag-symbol))) + ((= pos 0) `(memq (car-safe cl-x) ,tag-symbol)) + (t `(and (consp cl-x) (memq (nth ,pos cl-x) ,tag-symbol)))))) pred-check (and pred-form (> safety 0) (if (and (eq (cl-caadr pred-form) 'vectorp) (= safety 1)) - (cons 'and (cl-cdddr pred-form)) pred-form))) + (cons 'and (cl-cdddr pred-form)) + `(,predicate cl-x)))) (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) @@ -2435,14 +2671,15 @@ non-nil value, that slot cannot be set via `setf'. (push slot slots) (push (nth 1 desc) defaults) (push `(cl-defsubst ,accessor (cl-x) + (declare (side-effect-free t)) ,@(and pred-check (list `(or ,pred-check - (error "%s accessing a non-%s" - ',accessor ',name)))) - ,(if (eq type 'vector) `(aref cl-x ,pos) + (signal 'wrong-type-argument + (list ',name cl-x))))) + ,(if (memq type '(nil vector)) `(aref cl-x ,pos) (if (= pos 0) '(car cl-x) - `(nth ,pos cl-x)))) forms) - (push (cons accessor t) side-eff) + `(nth ,pos cl-x)))) + forms) (if (cadr (memq :read-only (cddr desc))) (push `(gv-define-expander ,accessor (lambda (_cl-do _cl-x) @@ -2473,30 +2710,32 @@ non-nil value, that slot cannot be set via `setf'. (setq pos (1+ pos)))) (setq slots (nreverse slots) defaults (nreverse defaults)) - (and predicate pred-form - (progn (push `(cl-defsubst ,predicate (cl-x) - ,(if (eq (car pred-form) 'and) - (append pred-form '(t)) - `(and ,pred-form t))) forms) - (push (cons predicate 'error-free) side-eff))) + (when pred-form + (push `(cl-defsubst ,predicate (cl-x) + (declare (side-effect-free error-free)) + ,(if (eq (car pred-form) 'and) + (append pred-form '(t)) + `(and ,pred-form t))) + forms) + (push `(put ',name 'cl-deftype-satisfies ',predicate) forms)) (and copier - (progn (push `(defun ,copier (x) (copy-sequence x)) forms) - (push (cons copier t) side-eff))) + (push `(defalias ',copier #'copy-sequence) forms)) (if constructor (push (list constructor - (cons '&key (delq nil (copy-sequence slots)))) - constrs)) - (while constrs - (let* ((name (caar constrs)) - (args (cadr (pop constrs))) - (anames (cl--arglist-args args)) + (cons '&key (delq nil (copy-sequence slots)))) + constrs)) + (pcase-dolist (`(,cname ,args ,doc) constrs) + (let* ((anames (cl--arglist-args args)) (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) - (push `(cl-defsubst ,name - (&cl-defs '(nil ,@descs) ,@args) - (,type ,@make)) forms) - (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) - (push (cons name t) side-eff)))) + (push `(cl-defsubst ,cname + (&cl-defs (nil ,@descs) ,@args) + ,(if (stringp doc) (list doc) + (format "Constructor for objects of type `%s'." name)) + ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) + '((declare (side-effect-free t)))) + (,(or type #'vector) ,@make)) + forms))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) ;; Don't bother adding to cl-custom-print-functions since it's not used ;; by anything anyway! @@ -2509,81 +2748,201 @@ non-nil value, that slot cannot be set via `setf'. ;; (and ,pred-form ,print-func)) ;; cl-custom-print-functions)) ;; forms)) - (push `(setq ,tag-symbol (list ',tag)) forms) - (push `(cl-eval-when (compile load eval) - (put ',name 'cl-struct-slots ',descs) - (put ',name 'cl-struct-type ',(list type (eq named t))) - (put ',name 'cl-struct-include ',include) - (put ',name 'cl-struct-print ,print-auto) - ,@(mapcar (lambda (x) - `(put ',(car x) 'side-effect-free ',(cdr x))) - side-eff)) - forms) - `(progn ,@(nreverse (cons `',name forms))))) - -;;; Types and assertions. + `(progn + (defvar ,tag-symbol) + ,@(nreverse forms) + ;; Call cl-struct-define during compilation as well, so that + ;; a subsequent cl-defstruct in the same file can correctly include this + ;; struct as a parent. + (eval-and-compile + (cl-struct-define ',name ,docstring ',include-name + ',type ,(eq named t) ',descs ',tag-symbol ',tag + ',print-auto)) + ',name))) + +;;; Add cl-struct support to pcase + +(defun cl--struct-all-parents (class) + (when (cl--struct-class-p class) + (let ((res ()) + (classes (list class))) + ;; BFS precedence. + (while (let ((class (pop classes))) + (push class res) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse res)))) ;;;###autoload -(defmacro cl-deftype (name arglist &rest body) - "Define NAME as a new data type. -The type name can then be used in `cl-typecase', `cl-check-type', etc." - (declare (debug cl-defmacro) (doc-string 3)) - `(cl-eval-when (compile load eval) - (put ',name 'cl-deftype-handler - (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body))))) - -(defun cl--make-type-test (val type) - (if (symbolp type) - (cond ((get type 'cl-deftype-handler) - (cl--make-type-test val (funcall (get type 'cl-deftype-handler)))) - ((memq type '(nil t)) type) - ((eq type 'null) `(null ,val)) - ((eq type 'atom) `(atom ,val)) - ((eq type 'float) `(floatp ,val)) - ((eq type 'real) `(numberp ,val)) - ((eq type 'fixnum) `(integerp ,val)) - ;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef - ((memq type '(character string-char)) `(characterp ,val)) - (t - (let* ((name (symbol-name type)) - (namep (intern (concat name "p")))) - (if (fboundp namep) (list namep val) - (list (intern (concat name "-p")) val))))) - (cond ((get (car type) 'cl-deftype-handler) - (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler) - (cdr type)))) - ((memq (car type) '(integer float real number)) - (delq t `(and ,(cl--make-type-test val (car type)) - ,(if (memq (cadr type) '(* nil)) t - (if (consp (cadr type)) `(> ,val ,(cl-caadr type)) - `(>= ,val ,(cadr type)))) - ,(if (memq (cl-caddr type) '(* nil)) t - (if (consp (cl-caddr type)) - `(< ,val ,(cl-caaddr type)) - `(<= ,val ,(cl-caddr type))))))) - ((memq (car type) '(and or not)) - (cons (car type) - (mapcar (function (lambda (x) (cl--make-type-test val x))) - (cdr type)))) - ((memq (car type) '(member cl-member)) - `(and (cl-member ,val ',(cdr type)) t)) - ((eq (car type) 'satisfies) (list (cadr type) val)) - (t (error "Bad type spec: %s" type))))) - -(defvar cl--object) +(pcase-defmacro cl-struct (type &rest fields) + "Pcase patterns to match cl-structs. +Elements of FIELDS can be of the form (NAME PAT) in which case the contents of +field NAME is matched against PAT, or they can be of the form NAME which +is a shorthand for (NAME NAME)." + (declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp]))) + `(and (pred (pcase--flip cl-typep ',type)) + ,@(mapcar + (lambda (field) + (let* ((name (if (consp field) (car field) field)) + (pat (if (consp field) (cadr field) field))) + `(app ,(if (eq (cl-struct-sequence-type type) 'list) + `(nth ,(cl-struct-slot-offset type name)) + `(pcase--flip aref ,(cl-struct-slot-offset type name))) + ,pat))) + fields))) + +(defun cl--pcase-mutually-exclusive-p (orig pred1 pred2) + "Extra special cases for `cl-typep' predicates." + (let* ((x1 pred1) (x2 pred2) + (t1 + (and (eq 'pcase--flip (car-safe x1)) (setq x1 (cdr x1)) + (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1)) + (null (cdr-safe x1)) (setq x1 (car x1)) + (eq 'quote (car-safe x1)) (cadr x1))) + (t2 + (and (eq 'pcase--flip (car-safe x2)) (setq x2 (cdr x2)) + (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2)) + (null (cdr-safe x2)) (setq x2 (car x2)) + (eq 'quote (car-safe x2)) (cadr x2)))) + (or + (and (symbolp t1) (symbolp t2) + (let ((c1 (cl--find-class t1)) + (c2 (cl--find-class t2))) + (and c1 c2 + (not (or (memq c1 (cl--struct-all-parents c2)) + (memq c2 (cl--struct-all-parents c1))))))) + (let ((c1 (and (symbolp t1) (cl--find-class t1)))) + (and c1 (cl--struct-class-p c1) + (funcall orig (if (eq 'list (cl-struct-sequence-type t1)) + 'consp 'vectorp) + pred2))) + (let ((c2 (and (symbolp t2) (cl--find-class t2)))) + (and c2 (cl--struct-class-p c2) + (funcall orig pred1 + (if (eq 'list (cl-struct-sequence-type t2)) + 'consp 'vectorp)))) + (funcall orig pred1 pred2)))) +(advice-add 'pcase--mutually-exclusive-p + :around #'cl--pcase-mutually-exclusive-p) + + +(defun cl-struct-sequence-type (struct-type) + "Return the sequence used to build STRUCT-TYPE. +STRUCT-TYPE is a symbol naming a struct type. Return 'vector or +'list, or nil if STRUCT-TYPE is not a struct type. " + (declare (side-effect-free t) (pure t)) + (cl--struct-class-type (cl--struct-get-class struct-type))) + +(defun cl-struct-slot-info (struct-type) + "Return a list of slot names of struct STRUCT-TYPE. +Each entry is a list (SLOT-NAME . OPTS), where SLOT-NAME is a +slot name symbol and OPTS is a list of slot options given to +`cl-defstruct'. Dummy slots that represent the struct name and +slots skipped by :initial-offset may appear in the list." + (declare (side-effect-free t) (pure t)) + (let* ((class (cl--struct-get-class struct-type)) + (slots (cl--struct-class-slots class)) + (type (cl--struct-class-type class)) + (descs (if type () (list '(cl-tag-slot))))) + (dotimes (i (length slots)) + (let ((slot (aref slots i))) + (push `(,(cl--slot-descriptor-name slot) + ,(cl--slot-descriptor-initform slot) + ,@(if (not (eq (cl--slot-descriptor-type slot) t)) + `(:type ,(cl--slot-descriptor-type slot))) + ,@(cl--slot-descriptor-props slot)) + descs))) + (nreverse descs))) + +(define-error 'cl-struct-unknown-slot "struct %S has no slot %S") + +(defun cl-struct-slot-offset (struct-type slot-name) + "Return the offset of slot SLOT-NAME in STRUCT-TYPE. +The returned zero-based slot index is relative to the start of +the structure data type and is adjusted for any structure name +and :initial-offset slots. Signal error if struct STRUCT-TYPE +does not contain SLOT-NAME." + (declare (side-effect-free t) (pure t)) + (or (gethash slot-name + (cl--class-index-table (cl--struct-get-class struct-type))) + (signal 'cl-struct-unknown-slot (list struct-type slot-name)))) + +(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)))))) + +(put 'null 'cl-deftype-satisfies #'null) +(put 'atom 'cl-deftype-satisfies #'atom) +(put 'real 'cl-deftype-satisfies #'numberp) +(put 'fixnum 'cl-deftype-satisfies #'integerp) +(put 'base-char 'cl-deftype-satisfies #'characterp) +(put 'character 'cl-deftype-satisfies #'integerp) + + ;;;###autoload -(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)) +(define-inline cl-typep (val type) + (inline-letevals (val) + (pcase (inline-const-val type) + ((and `(,name . ,args) (guard (get name 'cl-deftype-handler))) + (inline-quote + (cl-typep ,val ',(apply (get name 'cl-deftype-handler) args)))) + (`(,(and name (or 'integer 'float 'real 'number)) + . ,(or `(,min ,max) pcase--dontcare)) + (inline-quote + (and (cl-typep ,val ',name) + ,(if (memq min '(* nil)) t + (if (consp min) + (inline-quote (> ,val ',(car min))) + (inline-quote (>= ,val ',min)))) + ,(if (memq max '(* nil)) t + (if (consp max) + (inline-quote (< ,val ',(car max))) + (inline-quote (<= ,val ',max))))))) + (`(not ,type) (inline-quote (not (cl-typep ,val ',type)))) + (`(,(and name (or 'and 'or)) . ,types) + (cond + ((null types) (inline-quote ',(eq name 'and))) + ((null (cdr types)) + (inline-quote (cl-typep ,val ',(car types)))) + (t + (let ((head (car types)) + (rest `(,name . ,(cdr types)))) + (cond + ((eq name 'and) + (inline-quote (and (cl-typep ,val ',head) + (cl-typep ,val ',rest)))) + (t + (inline-quote (or (cl-typep ,val ',head) + (cl-typep ,val ',rest))))))))) + (`(eql ,v) (inline-quote (and (eql ,val ',v) t))) + (`(member . ,args) (inline-quote (and (memql ,val ',args) t))) + (`(satisfies ,pred) (inline-quote (funcall #',pred ,val))) + ((and (pred symbolp) type (guard (get type 'cl-deftype-handler))) + (inline-quote + (cl-typep ,val ',(funcall (get type 'cl-deftype-handler))))) + ((and (pred symbolp) type (guard (get type 'cl-deftype-satisfies))) + (inline-quote (funcall #',(get type 'cl-deftype-satisfies) ,val))) + ((and (or 'nil 't) type) (inline-quote ',type)) + ((and (pred symbolp) type) + (let* ((name (symbol-name type)) + (namep (intern (concat name "p")))) + (cond + ((cl--macroexp-fboundp namep) (inline-quote (funcall #',namep ,val))) + ((cl--macroexp-fboundp + (setq namep (intern (concat name "-p")))) + (inline-quote (funcall #',namep ,val))) + ((cl--macroexp-fboundp type) (inline-quote (funcall #',type ,val))) + (t (error "Unknown type %S" type))))) + (type (error "Bad type spec: %s" type))))) + ;;;###autoload (defmacro cl-check-type (form type &optional string) @@ -2592,14 +2951,11 @@ STRING is an optional description of the desired type." (declare (debug (place cl-type-spec &optional stringp))) (and (or (not (cl--compiling-file)) (< cl--optimize-speed 3) (= cl--optimize-safety 3)) - (let* ((temp (if (cl--simple-expr-p form 3) - form (make-symbol "--cl-var--"))) - (body `(or ,(cl--make-type-test temp type) - (signal 'wrong-type-argument - (list ,(or string `',type) - ,temp ',form))))) - (if (eq temp form) `(progn ,body nil) - `(let ((,temp ,form)) ,body nil))))) + (macroexp-let2 macroexp-copyable-p temp form + `(progn (or (cl-typep ,temp ',type) + (signal 'wrong-type-argument + (list ,(or string `',type) ,temp ',form))) + nil)))) ;;;###autoload (defmacro cl-assert (form &optional show-args string &rest args) @@ -2619,10 +2975,9 @@ omitted, a default message listing FORM itself is used." (cdr form)))))) `(progn (or ,form - ,(if string - `(error ,string ,@sargs ,@args) - `(signal 'cl-assertion-failed - (list ',form ,@sargs)))) + (cl--assertion-failed + ',form ,@(if (or string sargs args) + `(,string (list ,@sargs) (list ,@args))))) nil)))) ;;; Compiler macros. @@ -2639,11 +2994,16 @@ 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))))) - (let ((fname (make-symbol (concat (symbol-name func) "--cmacro")))) + ;; FIXME: The code in bytecomp mishandles top-level expressions that define + ;; uninterned functions. E.g. it would generate code like: + ;; (defalias '#1=#:foo--cmacro #[514 ...]) + ;; (put 'foo 'compiler-macro '#:foo--cmacro) + ;; So we circumvent this by using an interned name. + (let ((fname (intern (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) @@ -2677,12 +3037,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) @@ -2690,67 +3050,6 @@ macro that returns its `&whole' argument." (if cl-found (setcdr cl-found t))) `(throw ,cl-tag ,cl-value)) -;;;###autoload -(defmacro cl-defsubst (name args &rest body) - "Define NAME as a function. -Like `defun', except the function is automatically declared `inline', -ARGLIST allows full Common Lisp conventions, and BODY is implicitly -surrounded by (cl-block NAME ...). - -\(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)))) - (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p)) - `(progn - ,(if p nil ; give up if defaults refer to earlier args - `(cl-define-compiler-macro ,name - ,(if (memq '&key args) - `(&whole cl-whole &cl-quote ,@args) - (cons '&cl-quote args)) - (cl--defsubst-expand - ',argns '(cl-block ,name ,@body) - ;; We used to pass `simple' as - ;; (not (or unsafe (cl-expr-access-order pbody argns))) - ;; But this is much too simplistic since it - ;; does not pay attention to the argvs (and - ;; cl-expr-access-order itself is also too naive). - nil - ,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns))) - (cl-defun ,name ,args ,@body)))) - -(defun cl--defsubst-expand (argns body simple whole unsafe &rest argvs) - (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole - (if (cl--simple-exprs-p argvs) (setq simple t)) - (let* ((substs ()) - (lets (delq nil - (cl-mapcar (lambda (argn argv) - (if (or simple (macroexp-const-p argv)) - (progn (push (cons argn argv) substs) - (and unsafe (list argn argv))) - (list argn argv))) - argns argvs)))) - ;; FIXME: `sublis/subst' will happily substitute the symbol - ;; `argn' in places where it's not used as a reference - ;; to a variable. - ;; FIXME: `sublis/subst' will happily copy `argv' to a different - ;; scope, leading to name capture. - (setq body (cond ((null substs) body) - ((null (cdr substs)) - (cl-subst (cdar substs) (caar substs) body)) - (t (cl--sublis substs body)))) - (if lets `(let ,lets ,body) body)))) - -(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. (defun cl--compiler-macro-member (form a list &rest keys) @@ -2774,9 +3073,8 @@ surrounded by (cl-block NAME ...). ;;;###autoload (defun cl--compiler-macro-adjoin (form a list &rest keys) (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)))))) + (macroexp-let2* macroexp-copyable-p ((va a) (vlist list)) + `(if (cl-member ,va ,vlist ,@keys) ,vlist (cons ,va ,vlist))))) (defun cl--compiler-macro-get (_form sym prop &optional def) (if def @@ -2799,19 +3097,50 @@ surrounded by (cl-block NAME ...). ;;; Things that are inline. (cl-proclaim '(inline cl-acons cl-map cl-concatenate cl-notany - cl-notevery cl--set-elt cl-revappend cl-nreconc gethash)) + cl-notevery cl-revappend cl-nreconc gethash)) ;;; Things that are side-effect-free. -(mapc (lambda (x) (put x 'side-effect-free t)) +(mapc (lambda (x) (function-put x 'side-effect-free t)) '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-subseq cl-list-length cl-get cl-getf)) ;;; Things that are side-effect-and-error-free. -(mapc (lambda (x) (put x 'side-effect-free 'error-free)) +(mapc (lambda (x) (function-put x 'side-effect-free 'error-free)) '(eql cl-list* cl-subst cl-acons cl-equalp cl-random-state-p copy-tree cl-sublis)) +;;; Types and assertions. + +;;;###autoload +(defmacro cl-deftype (name arglist &rest body) + "Define NAME as a new data type. +The type name can then be used in `cl-typecase', `cl-check-type', etc." + (declare (debug cl-defmacro) (doc-string 3) (indent 2)) + `(cl-eval-when (compile load eval) + (put ',name 'cl-deftype-handler + (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body))))) + +(cl-deftype extended-char () `(and character (not base-char))) + +;;; Additional functions that we can now define because we've defined +;;; `cl-defsubst' and `cl-typep'. + +(define-inline cl-struct-slot-value (struct-type slot-name inst) + "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE. +STRUCT and SLOT-NAME are symbols. INST is a structure instance." + (declare (side-effect-free t)) + (inline-letevals (struct-type slot-name inst) + (inline-quote + (progn + (unless (cl-typep ,inst ,struct-type) + (signal 'wrong-type-argument (list ,struct-type ,inst))) + ;; We could use `elt', but since the byte compiler will resolve the + ;; branch below at compile time, it's more efficient to use the + ;; type-specific accessor. + (if (eq (cl-struct-sequence-type ,struct-type) 'list) + (nth (cl-struct-slot-offset ,struct-type ,slot-name) ,inst) + (aref ,inst (cl-struct-slot-offset ,struct-type ,slot-name))))))) (run-hooks 'cl-macs-load-hook) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el new file mode 100644 index 00000000000..03480b2756b --- /dev/null +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -0,0 +1,265 @@ +;;; cl-preloaded.el --- Preloaded part of the CL library -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; 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 cl-defstruct macro is full of circularities, since it uses the +;; cl-structure-class type (and its accessors) which is defined with itself, +;; and it setups a default parent (cl-structure-object) which is also defined +;; with cl-defstruct, and to make things more interesting, the class of +;; cl-structure-object is of course an object of type cl-structure-class while +;; cl-structure-class's parent is cl-structure-object. +;; Furthermore, the code generated by cl-defstruct generally assumes that the +;; parent will be loaded when the child is loaded. But at the same time, the +;; expectation is that structs defined with cl-defstruct do not need cl-lib at +;; run-time, which means that the `cl-structure-object' parent can't be in +;; cl-lib but should be preloaded. So here's this preloaded circular setup. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'cl-macs)) ;For cl--struct-class. + +;; 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")) + +(defun cl--assertion-failed (form &optional string sargs args) + (if debug-on-error + (debug `(cl-assertion-failed ,form ,string ,@sargs)) + (if string + (apply #'error string (append sargs args)) + (signal 'cl-assertion-failed `(,form ,@sargs))))) + +;; When we load this (compiled) file during pre-loading, the cl--struct-class +;; code below will need to access the `cl-struct' info, since it's considered +;; already as its parent (because `cl-struct' was defined while the file was +;; compiled). So let's temporarily setup a fake. +(defvar cl-struct-cl-structure-object-tags nil) +(unless (cl--find-class 'cl-structure-object) + (setf (cl--find-class 'cl-structure-object) 'dummy)) + +(fset 'cl--make-slot-desc + ;; To break circularity, we pre-define the slot constructor by hand. + ;; It's redefined a bit further down as part of the cl-defstruct of + ;; cl--slot-descriptor. + ;; BEWARE: Obviously, it's important to keep the two in sync! + (lambda (name &optional initform type props) + (vector 'cl-struct-cl-slot-descriptor + name initform type props))) + +(defun cl--struct-get-class (name) + (or (if (not (symbolp name)) name) + (cl--find-class name) + (if (not (get name 'cl-struct-type)) + ;; FIXME: Add a conversion for `eieio--class' so we can + ;; create a cl-defstruct that inherits from an eieio class? + (error "%S is not a struct name" name) + ;; Backward compatibility with a defstruct compiled with a version + ;; cl-defstruct from Emacs<25. Convert to new format. + (let ((tag (intern (format "cl-struct-%s" name))) + (type-and-named (get name 'cl-struct-type)) + (descs (get name 'cl-struct-slots))) + (cl-struct-define name nil (get name 'cl-struct-include) + (unless (and (eq (car type-and-named) 'vector) + (null (cadr type-and-named)) + (assq 'cl-tag-slot descs)) + (car type-and-named)) + (cadr type-and-named) + descs + (intern (format "cl-struct-%s-tags" name)) + tag + (get name 'cl-struct-print)) + (cl--find-class name))))) + +(defun cl--plist-remove (plist member) + (cond + ((null plist) nil) + ((null member) plist) + ((eq plist member) (cddr plist)) + (t `(,(car plist) ,(cadr plist) ,@(cl--plist-remove (cddr plist) member))))) + +(defun cl--struct-register-child (parent tag) + ;; Can't use (cl-typep parent 'cl-structure-class) at this stage + ;; because `cl-structure-class' is defined later. + (while (vectorp parent) + (add-to-list (cl--struct-class-children-sym parent) tag) + ;; Only register ourselves as a child of the leftmost parent since structs + ;; can only only have one parent. + (setq parent (car (cl--struct-class-parents parent))))) + +;;;###autoload +(defun cl-struct-define (name docstring parent type named slots children-sym + tag print) + (cl-assert (or type (not named))) + (if (boundp children-sym) + (add-to-list children-sym tag) + (set children-sym (list tag))) + (and (null type) (eq (caar slots) 'cl-tag-slot) + ;; Hide the tag slot from "standard" (i.e. non-`type'd) structs. + (setq slots (cdr slots))) + (let* ((parent-class (when parent (cl--struct-get-class parent))) + (n (length slots)) + (index-table (make-hash-table :test 'eq :size n)) + (vslots (let ((v (make-vector n nil)) + (i 0) + (offset (if type 0 1))) + (dolist (slot slots) + (let* ((props (cddr slot)) + (typep (plist-member props :type)) + (type (if typep (cadr typep) t))) + (aset v i (cl--make-slot-desc + (car slot) (nth 1 slot) + type (cl--plist-remove props typep)))) + (puthash (car slot) (+ i offset) index-table) + (cl-incf i)) + v)) + (class (cl--struct-new-class + name docstring + (unless (symbolp parent-class) (list parent-class)) + type named vslots index-table children-sym tag print))) + (unless (symbolp parent-class) + (let ((pslots (cl--struct-class-slots parent-class))) + (or (>= n (length pslots)) + (let ((ok t)) + (dotimes (i (length pslots)) + (unless (eq (cl--slot-descriptor-name (aref pslots i)) + (cl--slot-descriptor-name (aref vslots i))) + (setq ok nil))) + ok) + (error "Included struct %S has changed since compilation of %S" + parent name)))) + (add-to-list 'current-load-list `(define-type . ,name)) + (cl--struct-register-child parent-class tag) + (unless (eq named t) + (eval `(defconst ,tag ',class) t) + ;; In the cl-generic support, we need to be able to check + ;; if a vector is a cl-struct object, without knowing its particular type. + ;; So we use the (otherwise) unused function slots of the tag symbol + ;; to put a special witness value, to make the check easy and reliable. + (fset tag :quick-object-witness-check)) + (setf (cl--find-class name) class))) + +(cl-defstruct (cl-structure-class + (:conc-name cl--struct-class-) + (:predicate cl--struct-class-p) + (:constructor nil) + (:constructor cl--struct-new-class + (name docstring parents type named slots index-table + children-sym tag print)) + (:copier nil)) + "The type of CL structs descriptors." + ;; The first few fields here are actually inherited from cl--class, but we + ;; have to define this one before, to break the circularity, so we manually + ;; list the fields here and later "backpatch" cl--class as the parent. + ;; BEWARE: Obviously, it's indispensable to keep these two structs in sync! + (name nil :type symbol) ;The type name. + (docstring nil :type string) + (parents nil :type (list-of cl--class)) ;The included struct. + (slots nil :type (vector cl--slot-descriptor)) + (index-table nil :type hash-table) + (tag nil :type symbol) ;Placed in cl-tag-slot. Holds the struct-class object. + (type nil :type (memq (vector list))) + (named nil :type bool) + (print nil :type bool) + (children-sym nil :type symbol) ;This sym's value holds the tags of children. + ) + +(cl-defstruct (cl-structure-object + (:predicate cl-struct-p) + (:constructor nil) + (:copier nil)) + "The root parent of all \"normal\" CL structs") + +(setq cl--struct-default-parent 'cl-structure-object) + +(cl-defstruct (cl-slot-descriptor + (:conc-name cl--slot-descriptor-) + (:constructor nil) + (:constructor cl--make-slot-descriptor + (name &optional initform type props)) + (:copier cl--copy-slot-descriptor-1)) + ;; FIXME: This is actually not used yet, for circularity reasons! + "Descriptor of structure slot." + name ;Attribute name (symbol). + initform + type + ;; Extra properties, kept in an alist, can include: + ;; :documentation, :protection, :custom, :label, :group, :printer. + (props nil :type alist)) + +(defun cl--copy-slot-descriptor (slot) + (let ((new (cl--copy-slot-descriptor-1 slot))) + (cl-callf copy-alist (cl--slot-descriptor-props new)) + new)) + +(cl-defstruct (cl--class + (:constructor nil) + (:copier nil)) + "Type of descriptors for any kind of structure-like data." + ;; Intended to be shared between defstruct and defclass. + (name nil :type symbol) ;The type name. + (docstring nil :type string) + ;; For structs there can only be one parent, but when EIEIO classes inherit + ;; from cl--class, we'll need this to hold a list. + (parents nil :type (list-of cl--class)) + (slots nil :type (vector cl-slot-descriptor)) + (index-table nil :type hash-table)) + +(cl-assert + (let ((sc-slots (cl--struct-class-slots (cl--find-class 'cl-structure-class))) + (c-slots (cl--struct-class-slots (cl--find-class 'cl--class))) + (eq t)) + (dotimes (i (length c-slots)) + (let ((sc-slot (aref sc-slots i)) + (c-slot (aref c-slots i))) + (unless (eq (cl--slot-descriptor-name sc-slot) + (cl--slot-descriptor-name c-slot)) + (setq eq nil)))) + eq)) + +;; Close the recursion between cl-structure-object and cl-structure-class. +(setf (cl--struct-class-parents (cl--find-class 'cl-structure-class)) + (list (cl--find-class 'cl--class))) +(cl--struct-register-child + (cl--find-class 'cl--class) + (cl--struct-class-tag (cl--find-class 'cl-structure-class))) + +(cl-assert (cl--find-class 'cl-structure-class)) +(cl-assert (cl--find-class 'cl-structure-object)) +(cl-assert (cl-struct-p (cl--find-class 'cl-structure-class))) +(cl-assert (cl-struct-p (cl--find-class 'cl-structure-object))) +(cl-assert (cl--class-p (cl--find-class 'cl-structure-class))) +(cl-assert (cl--class-p (cl--find-class 'cl-structure-object))) + +;; Make sure functions defined with cl-defsubst can be inlined even in +;; packages which do not require CL. We don't put an autoload cookie +;; directly on that function, since those cookies only go to cl-loaddefs. +(autoload 'cl--defsubst-expand "cl-macs") +;; Autoload, so autoload.el and font-lock can use it even when CL +;; is not loaded. +(put 'cl-defun 'doc-string-elt 3) +(put 'cl-defmacro 'doc-string-elt 3) +(put 'cl-defsubst 'doc-string-elt 3) +(put 'cl-defstruct 'doc-string-elt 2) + +(provide 'cl-preloaded) +;;; cl-preloaded.el ends here diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 6b5b329e33f..3aea67ad11b 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -1,6 +1,6 @@ ;;; cl-seq.el --- Common Lisp features, part 3 -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2015 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Old-Version: 2.02 @@ -166,7 +166,7 @@ SEQ1 is destructively modified, then returned. (cl-n (min (- (or cl-end1 cl-len) cl-start1) (- (or cl-end2 cl-len) cl-start2)))) (while (>= (setq cl-n (1- cl-n)) 0) - (cl--set-elt cl-seq1 (+ cl-start1 cl-n) + (setf (elt cl-seq1 (+ cl-start1 cl-n)) (elt cl-seq2 (+ cl-start2 cl-n)))))) (if (listp cl-seq1) (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) @@ -392,7 +392,7 @@ to avoid corrupting the original SEQ. cl-seq (setq cl-seq (copy-sequence cl-seq)) (or cl-from-end - (progn (cl--set-elt cl-seq cl-i cl-new) + (progn (setf (elt cl-seq cl-i) cl-new) (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count :start cl-i cl-keys)))))) @@ -439,7 +439,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (setq cl-end (1- cl-end)) (if (cl--check-test cl-old (elt cl-seq cl-end)) (progn - (cl--set-elt cl-seq cl-end cl-new) + (setf (elt cl-seq cl-end) cl-new) (setq cl-count (1- cl-count))))) (while (and (< cl-start cl-end) (> cl-count 0)) (if (cl--check-test cl-old (aref cl-seq cl-start)) @@ -1018,4 +1018,6 @@ Atoms are compared by `eql'; cons cells are compared recursively. ;; generated-autoload-file: "cl-loaddefs.el" ;; End: +(provide 'cl-seq) + ;;; cl-seq.el ends here diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index ea4d9511f9d..46472ccd257 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-2015 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions @@ -29,6 +29,7 @@ (require 'cl-lib) (require 'macroexp) +(require 'gv) ;; (defun cl--rename () ;; (let ((vdefs ()) @@ -341,6 +342,8 @@ The two cases that are handled are: - renaming of F when it's a function defined via `cl-labels' or `labels'." (require 'cl-macs) (declare-function cl--expr-contains-any "cl-macs" (x y)) + (declare-function cl--labels-convert "cl-macs" (f)) + (defvar cl--labels-convert-cache) (cond ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked ;; *after* handling `function', but we want to stop macroexpansion from @@ -373,13 +376,7 @@ The two cases that are handled are: (setq cl--function-convert-cache (cons newf res)) res)))) (t - (let ((found (assq f macroexpand-all-environment))) - (if (and found (ignore-errors - (eq (cadr (cl-caddr found)) 'cl-labels-args))) - (cadr (cl-caddr (cl-cadddr found))) - (let ((res `(function ,f))) - (setq cl--function-convert-cache (cons f res)) - res)))))) + (cl--labels-convert f)))) (defmacro lexical-let (bindings &rest body) "Like `let', but lexically scoped. @@ -400,7 +397,7 @@ lexical closures as in Common Lisp. (macroexpand-all `(cl-symbol-macrolet ,(mapcar (lambda (x) - `(,(car x) (symbol-value ,(cl-caddr x)))) + `(,(car x) (symbol-value ,(nth 2 x)))) vars) ,@body) (cons (cons 'function #'cl--function-convert) @@ -413,20 +410,20 @@ lexical closures as in Common Lisp. ;; dynamic scoping, since with lexical scoping we'd need ;; (let ((foo <val>)) ...foo...). `(progn - ,@(mapcar (lambda (x) `(defvar ,(cl-caddr x))) vars) - (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars) + ,@(mapcar (lambda (x) `(defvar ,(nth 2 x))) vars) + (let ,(mapcar (lambda (x) (list (nth 2 x) (nth 1 x))) vars) ,(cl-sublis (mapcar (lambda (x) - (cons (cl-caddr x) - `',(cl-caddr x))) + (cons (nth 2 x) + `',(nth 2 x))) vars) ebody))) `(let ,(mapcar (lambda (x) - (list (cl-caddr x) + (list (nth 2 x) `(make-symbol ,(format "--%s--" (car x))))) vars) (setf ,@(apply #'append (mapcar (lambda (x) - (list `(symbol-value ,(cl-caddr x)) (cadr x))) + (list `(symbol-value ,(nth 2 x)) (nth 1 x))) vars))) ,ebody)))) @@ -571,7 +568,7 @@ may be bound to temporary variables which are introduced automatically to preserve proper execution order of the arguments. For example: - (defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v)) + (defsetf nth (n x) (v) \\=`(setcar (nthcdr ,n ,x) ,v)) You can replace this form with `gv-define-setter'. @@ -629,6 +626,8 @@ You can replace this form with `gv-define-setter'. ;; ...the rest, and build the 5-tuple)) (make-obsolete 'get-setf-method 'gv-letplace "24.3") +(declare-function cl--arglist-args "cl-macs" (args)) + (defmacro define-modify-macro (name arglist func &optional doc) "Define a `setf'-like modify macro. If NAME is called, it combines its PLACE argument with the other @@ -642,6 +641,7 @@ You can replace this macro with `gv-letplace'." symbolp &optional stringp))) (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) + (require 'cl-macs) ;For cl--arglist-args. (let ((place (make-symbol "--cl-place--"))) `(cl-defmacro ,name (,place ,@arglist) ,doc diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index b3fc6fb887a..50f880d7b33 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-2015 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'. @@ -376,9 +375,4 @@ If FIX is non-nil, run `copyright-fix-years' instead." (provide 'copyright) -;; For the copyright sign: -;; Local Variables: -;; coding: utf-8 -;; End: - ;;; copyright.el ends here diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index b8e327625e7..61cb3c3af4e 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-2015 Free Software Foundation, Inc. ;; Author: Sen Nagata <sen@eccosys.com> ;; Keywords: completion, minibuffer, multiple elements @@ -24,27 +24,7 @@ ;; This code defines a function, `completing-read-multiple', which ;; provides the ability to read multiple strings in the minibuffer, -;; with completion. - -;; By using this functionality, a user may specify multiple strings at -;; a single prompt, optionally using completion. - -;; Multiple strings are specified by separating each of the strings -;; with a prespecified separator regexp. For example, if the -;; separator regexp is ",", the strings 'alice', 'bob', and -;; 'eve' would be specified as 'alice,bob,eve'. - -;; The default value for the separator regexp is the value of -;; `crm-default-separator' (comma). The separator regexp may be -;; changed by modifying the value of `crm-separator'. - -;; Contiguous strings of non-separator-characters are referred to as -;; 'elements'. In the aforementioned example, the elements are: -;; 'alice', 'bob', and 'eve'. - -;; 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'. +;; with completion. See that function's documentation for details. ;; For the moment, I have decided to not bind any special behavior to ;; the separator key. In the future, the separator key might be used @@ -96,14 +76,16 @@ ;; first revamped version ;;; Code: + +;; FIXME I don't see that this needs to exist as a separate variable. +;; crm-separator should suffice. (defconst crm-default-separator "[ \t]*,[ \t]*" - "Default separator regexp for `completing-read-multiple'.") + "Default value of `crm-separator'.") (defvar crm-separator crm-default-separator "Separator regexp used for separating strings in `completing-read-multiple'. It should be a regexp that does not match the list of completion candidates. -Modify this value to make `completing-read-multiple' use a separator other -than `crm-default-separator'.") +The default value is `crm-default-separator'.") (defvar crm-local-completion-map (let ((map (make-sparse-keymap))) @@ -146,8 +128,8 @@ A value of nil specifies `try-completion'. A value of t specifies `all-completions'. A value of lambda specifies a test for an exact match. For more information on STRING, PREDICATE, and FLAG, see the Elisp -Reference sections on 'Programmed Completion' and 'Basic Completion -Functions'." +Reference sections on “Programmed Completion” and “Basic Completion +Functions”." (let ((beg 0)) (while (string-match crm-separator string beg) (setq beg (match-end 0))) @@ -157,33 +139,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 +173,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 +197,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))) @@ -238,37 +222,29 @@ exiting the minibuffer." t)) ;; superemulates behavior of completing_read in src/minibuf.c +;; Use \\<crm-local-completion-map> so that help-enable-auto-load can +;; do its thing. Any keymap that is defined will do. ;;;###autoload (defun completing-read-multiple (prompt table &optional predicate require-match initial-input hist def inherit-input-method) "Read multiple strings in the minibuffer, with completion. -By using this functionality, a user may specify multiple strings at a -single prompt, optionally using completion. - -Multiple strings are specified by separating each of the strings with -a prespecified separator regexp. For example, if the separator -regexp is \",\", the strings 'alice', 'bob', and 'eve' would be -specified as 'alice,bob,eve'. +The arguments are the same as those of `completing-read'. +\\<crm-local-completion-map> +Input multiple strings by separating each one with a string that +matches the regexp `crm-separator'. For example, if the separator +regexp is \",\", entering \"alice,bob,eve\" specifies the strings +\"alice\", \"bob\", and \"eve\". -The default value for the separator regexp is the value of -`crm-default-separator' (comma). The separator regexp may be -changed by modifying the value of `crm-separator'. - -Contiguous strings of non-separator-characters are referred to as -'elements'. In the aforementioned example, the elements are: 'alice', -'bob', and 'eve'. +We refer to contiguous strings of non-separator-characters as +\"elements\". In this example there are three elements. 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 -with empty strings removed. +contents of the minibuffer are \"alice,bob,eve\" and point is between +\"l\" and \"i\", pressing \\[minibuffer-complete] operates on the element \"alice\". -See the documentation for `completing-read' for details on the arguments: -PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-INPUT, HIST, DEF, and -INHERIT-INPUT-METHOD." +This function returns a list of the strings that were read, +with empty strings removed." (unwind-protect (progn (add-hook 'choose-completion-string-functions diff --git a/lisp/emacs-lisp/cursor-sensor.el b/lisp/emacs-lisp/cursor-sensor.el new file mode 100644 index 00000000000..1d1780baed0 --- /dev/null +++ b/lisp/emacs-lisp/cursor-sensor.el @@ -0,0 +1,180 @@ +;;; cursor-sensor.el --- React to cursor movement -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package implements the `cursor-intangible' property, which is +;; meant to replace the old `intangible' property. To use it, just enable the +;; `cursor-intangible-mode', after which this package will move point away from +;; any position that has a non-nil `cursor-intangible' property. This is only +;; done just before redisplay happens, contrary to the old `intangible' +;; property which was done at a much lower level. + +;;; Code: + +(defvar cursor-sensor-inhibit nil) + +(defun cursor-sensor--intangible-p (pos) + (let ((p (get-pos-property pos 'cursor-intangible))) + (if p + (let (a b) + (if (and (setq a (get-char-property pos 'cursor-intangible)) + (setq b (if (> pos (point-min)) + (get-char-property (1- pos) 'cursor-intangible))) + (not (eq a b))) + ;; If we're right between two different intangible thingies, + ;; we can stop here. This is not quite consistent with the + ;; interpretation of "if it's sticky, then this boundary is + ;; itself intangible", but it's convenient (and it better matches + ;; the behavior of `intangible', making it easier to port code). + nil p)) + p))) + +(defun cursor-sensor-tangible-pos (curpos window &optional second-chance) + (let ((newpos curpos)) + (when (cursor-sensor--intangible-p newpos) + (let ((oldpos (window-parameter window 'cursor-intangible--last-point))) + (cond + ((or (and (integerp oldpos) (< oldpos newpos)) + (eq newpos (point-min))) + (while + (when (< newpos (point-max)) + (setq newpos + (if (get-char-property newpos 'cursor-intangible) + (next-single-char-property-change + newpos 'cursor-intangible nil (point-max)) + (1+ newpos))) + (cursor-sensor--intangible-p newpos)))) + (t ;; (>= oldpos newpos) + (while + (when (> newpos (point-min)) + (setq newpos + (if (get-char-property (1- newpos) 'cursor-intangible) + (previous-single-char-property-change + newpos 'cursor-intangible nil (point-min)) + (1- newpos))) + (cursor-sensor--intangible-p newpos))))) + (if (not (and (or (eq newpos (point-min)) (eq newpos (point-max))) + (cursor-sensor--intangible-p newpos))) + ;; All clear, we're good to go. + newpos + ;; We're still on an intangible position because we bumped + ;; into an intangible BOB/EOB: try to move in the other direction. + (if second-chance + ;; Actually, we tried already and that failed! + curpos + (cursor-sensor-tangible-pos newpos window 'second-chance))))))) + +(defun cursor-sensor-move-to-tangible (window) + (let* ((curpos (window-point window)) + (newpos (cursor-sensor-tangible-pos curpos window))) + (when newpos (set-window-point window newpos)) + (set-window-parameter window 'cursor-intangible--last-point + (or newpos curpos)))) + +(defun cursor-sensor--move-to-tangible (window) + (unless cursor-sensor-inhibit + (cursor-sensor-move-to-tangible window))) + +;;;###autoload +(define-minor-mode cursor-intangible-mode + "Keep cursor outside of any `cursor-intangible' text property." + nil nil nil + (if cursor-intangible-mode + (add-hook 'pre-redisplay-functions #'cursor-sensor--move-to-tangible + nil t) + (remove-hook 'pre-redisplay-functions #'cursor-sensor--move-to-tangible t))) + +;;; Detect cursor movement. + +(defun cursor-sensor--detect (window) + (unless cursor-sensor-inhibit + (let* ((point (window-point window)) + ;; It's often desirable to make the cursor-sensor-functions property + ;; non-sticky on both ends, but that means get-pos-property might + ;; never see it. + (new (or (get-char-property point 'cursor-sensor-functions) + (unless (bobp) + (get-char-property (1- point) 'cursor-sensor-functions)))) + (old (window-parameter window 'cursor-sensor--last-state)) + (oldposmark (car old)) + (oldpos (or (if oldposmark (marker-position oldposmark)) + (point-min))) + (start (min oldpos point)) + (end (max oldpos point))) + (unless (or (null old) (eq (marker-buffer oldposmark) (current-buffer))) + ;; `window' does not display the same buffer any more! + (setcdr old nil)) + (if (or (and (null new) (null (cdr old))) + (and (eq new (cdr old)) + (eq (next-single-property-change + start 'cursor-sensor-functions nil end) + end))) + ;; Clearly nothing to do. + nil + ;; Maybe something to do. Let's see exactly what needs to run. + (let* ((missing-p + (lambda (f) + "Non-nil if F is missing somewhere between START and END." + (let ((pos start) + (missing nil)) + (while (< pos end) + (setq pos (next-single-property-change + pos 'cursor-sensor-functions + nil end)) + (unless (memq f (get-char-property + pos 'cursor-sensor-functions)) + (setq missing t))) + missing)))) + (dolist (f (cdr old)) + (unless (and (memq f new) (not (funcall missing-p f))) + (funcall f window oldpos 'left))) + (dolist (f new) + (unless (and (memq f (cdr old)) (not (funcall missing-p f))) + (funcall f window oldpos 'entered))))) + + ;; Remember current state for next time. + ;; Re-read cursor-sensor-functions since the functions may have moved + ;; window-point! + (if old + (progn (move-marker (car old) point) + (setcdr old new)) + (set-window-parameter window 'cursor-sensor--last-state + (cons (copy-marker point) new)))))) + +;;;###autoload +(define-minor-mode cursor-sensor-mode + "Handle the `cursor-sensor-functions' text property. +This property should hold a list of functions which react to the motion +of the cursor. They're called with three arguments (WINDOW OLDPOS DIR) +where WINDOW is the affected window, OLDPOS is the last known position of +the cursor and DIR can be `left' or `entered' depending on whether the cursor is +entering the area covered by the text-property property or leaving it." + nil nil nil + (if cursor-sensor-mode + (add-hook 'pre-redisplay-functions #'cursor-sensor--detect + nil t) + (remove-hook 'pre-redisplay-functions #'cursor-sensor--detect + t))) + +(provide 'cursor-sensor) +;;; cursor-sensor.el ends here diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 709a094e73b..0e307fae70a 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-2015 Free Software Foundation, ;; Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, tools, maint ;; This file is part of GNU Emacs. @@ -54,7 +54,7 @@ the middle is discarded, and just the beginning and end are displayed." The value affects the behavior of operations on any window previously showing the debugger buffer. -`nil' means that if its window is not deleted when exiting the +nil means that if its window is not deleted when exiting the debugger, invoking `switch-to-prev-buffer' will usually show the debugger buffer again. @@ -106,10 +106,10 @@ This is to optimize `debugger-make-xrefs'.") "Non-nil if we expect to get back in the debugger soon.") (defvar inhibit-debug-on-entry nil - "Non-nil means that debug-on-entry is disabled.") + "Non-nil means that `debug-on-entry' is disabled.") (defvar debugger-jumping-flag nil - "Non-nil means that debug-on-entry is disabled. + "Non-nil means that `debug-on-entry' is disabled. This variable is used by `debugger-jump', `debugger-step-through', and `debugger-reenable' to temporarily disable debug-on-entry.") @@ -165,7 +165,6 @@ first will be printed into the backtrace buffer." ;; Don't let these magic variables affect the debugger itself. (let ((last-command nil) this-command track-mouse (inhibit-trace t) - (inhibit-debug-on-entry t) unread-command-events unread-post-input-method-events last-input-event last-command-event last-nonmenu-event @@ -193,8 +192,10 @@ first will be printed into the backtrace buffer." debugger-buffer `((display-buffer-reuse-window display-buffer-in-previous-window) - . (,(when debugger-previous-window - `(previous-window . ,debugger-previous-window))))) + . (,(when (and (window-live-p debugger-previous-window) + (frame-visible-p + (window-frame debugger-previous-window))) + `(previous-window . ,debugger-previous-window))))) (setq debugger-window (selected-window)) (if (eq debugger-previous-window debugger-window) (when debugger-jumping-flag @@ -204,7 +205,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) @@ -236,7 +237,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) @@ -494,9 +495,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 " *;;;") @@ -531,16 +536,20 @@ Applies to the frame whose line point is on in the backtrace." (defmacro debugger-env-macro (&rest body) "Run BODY in original environment." (declare (indent 0)) - `(save-excursion - (if (null (buffer-live-p debugger-old-buffer)) - ;; old buffer deleted - (setq debugger-old-buffer (current-buffer))) - (set-buffer debugger-old-buffer) + `(progn (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." @@ -549,15 +558,70 @@ The environment used is the one when entering the activation frame at point." (let ((nframe (or nframe (condition-case nil (1+ (debugger-frame-number 'skip-base)) (error 0)))) ;; If on first line. - (base (if (eq 'debug--implement-debug-on-entry - (cadr (backtrace-frame 1 'debug))) - 'debug--implement-debug-on-entry 'debug))) + (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)) @@ -575,6 +639,7 @@ The environment used is the one when entering the activation frame at point." (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) @@ -626,7 +691,7 @@ The environment used is the one when entering the activation frame at point." (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. @@ -641,13 +706,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]." @@ -670,14 +731,11 @@ Complete list of commands: (buffer-substring (line-beginning-position 0) (line-end-position 0))))) -(declare-function help-xref-interned "help-mode" (symbol)) - (defun debug-help-follow (&optional pos) "Follow cross-reference at POS, defaulting to point. For the cross-reference format, see `help-make-xrefs'." (interactive "d") - (require 'help-mode) ;; Ideally we'd just do (call-interactively 'help-follow) except that this ;; assumes we're already in a *Help* buffer and reuses it, so it ends up ;; incorrectly "reusing" the *Backtrace* buffer to show the help info. @@ -693,7 +751,7 @@ For the cross-reference format, see `help-make-xrefs'." (progn (skip-syntax-forward "w_") (point))))))) (when (or (boundp sym) (fboundp sym) (facep sym)) - (help-xref-interned sym))))) + (describe-symbol sym))))) ;; When you change this, you may also need to change the number of ;; frames that the debugger skips. @@ -703,7 +761,8 @@ A call to this function is inserted by `debug-on-entry' to cause functions to break on entry." (if (or inhibit-debug-on-entry debugger-jumping-flag) nil - (funcall debugger 'debug))) + (let ((inhibit-debug-on-entry t)) + (funcall debugger 'debug)))) ;;;###autoload (defun debug-on-entry (function) @@ -734,7 +793,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 () @@ -764,7 +824,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 96c223c9e18..ee137f1771e 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-2015 Free Software Foundation, ;; Inc. ;; Author: David Megginson (dmeggins@aix1.uottawa.ca) -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: extensions ;; Package: emacs @@ -162,7 +162,8 @@ The new mode runs the hook constructed by the function See Info node `(elisp)Derived Modes' for more details." (declare (debug (&define name symbolp sexp [&optional stringp] [&rest keywordp sexp] def-body)) - (doc-string 4)) + (doc-string 4) + (indent 3)) (when (and docstring (not (stringp docstring))) ;; Some trickiness, since what appears to be the docstring may really be @@ -330,8 +331,11 @@ which more-or-less shadow%s %s's corresponding table%s." "\n\nThis mode " (concat "\n\nIn addition to any hooks its parent mode " - (if (string-match (regexp-quote (format "`%s'" parent)) - docstring) nil + (if (string-match (format "[`‘]%s['’]" + (regexp-quote + (symbol-name parent))) + docstring) + nil (format "`%s' " parent)) "might have run,\nthis mode ")) (format "runs the hook `%s'" hook) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index dc0e55df500..12cf605cce9 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 +;;; disass.el --- disassembler for compiled Emacs Lisp code -*- lexical-binding:t -*- -;; Copyright (C) 1986, 1991, 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 1986, 1991, 2002-2015 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. @@ -37,9 +37,9 @@ (require 'macroexp) -;;; The variable byte-code-vector is defined by the new bytecomp.el. -;;; The function byte-decompile-lapcode is defined in byte-opt.el. -;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. +;; The variable byte-code-vector is defined by the new bytecomp.el. +;; The function byte-decompile-lapcode is defined in byte-opt.el. +;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. (require 'byte-compile "bytecomp") (defvar disassemble-column-1-indent 8 "*") @@ -57,8 +57,8 @@ redefine OBJECT if it is a symbol." (interactive (list (intern (completing-read "Disassemble function: " obarray 'fboundp t)) nil 0 t)) - (if (and (consp object) (not (eq (car object) 'lambda))) - (setq object (list 'lambda () object))) + (if (and (consp object) (not (functionp object))) + (setq object `(lambda () ,object))) (or indent (setq indent 0)) ;Default indent to zero (save-excursion (if (or interactive-p (null buffer)) @@ -72,37 +72,34 @@ redefine OBJECT if it is a symbol." (defun disassemble-internal (obj indent interactive-p) (let ((macro 'nil) - (name 'nil) - (doc 'nil) + (name (when (symbolp obj) + (prog1 obj + (setq obj (indirect-function obj))))) args) - (while (symbolp obj) - (setq name obj - obj (symbol-function obj))) + (setq obj (autoload-do-load obj name)) (if (subrp obj) (error "Can't disassemble #<subr %s>" name)) - (setq obj (autoload-do-load obj name)) (if (eq (car-safe obj) 'macro) ;Handle macros. (setq macro t obj (cdr obj))) - (if (and (listp obj) (eq (car obj) 'byte-code)) - (setq obj (list 'lambda nil obj))) - (if (and (listp obj) (not (eq (car obj) 'lambda))) - (error "not a function")) - (if (consp obj) - (if (assq 'byte-code obj) - nil - (if interactive-p (message (if name - "Compiling %s's definition..." - "Compiling definition...") - name)) - (setq obj (byte-compile obj)) - (if interactive-p (message "Done compiling. Disassembling...")))) + (if (eq (car-safe obj) 'byte-code) + (setq obj `(lambda () ,obj))) + (when (consp obj) + (unless (functionp obj) (error "not a function")) + (if (assq 'byte-code obj) + nil + (if interactive-p (message (if name + "Compiling %s's definition..." + "Compiling definition...") + name)) + (setq obj (byte-compile obj)) + (if interactive-p (message "Done compiling. Disassembling...")))) (cond ((consp obj) + (setq args (help-function-arglist obj)) ;save arg list (setq obj (cdr obj)) ;throw lambda away - (setq args (car obj)) ;save arg list (setq obj (cdr obj))) ((byte-code-function-p obj) - (setq args (aref obj 0))) + (setq args (help-function-arglist obj))) (t (error "Compilation failed"))) (if (zerop indent) ; not a nested function (progn @@ -127,10 +124,7 @@ redefine OBJECT if it is a symbol." (insert " args: ") (prin1 args (current-buffer)) (insert "\n") - (let ((interactive (cond ((consp obj) - (assq 'interactive obj)) - ((> (length obj) 5) - (list 'interactive (aref obj 5)))))) + (let ((interactive (interactive-form obj))) (if interactive (progn (setq interactive (nth 1 interactive)) @@ -226,15 +220,16 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." ;; but if the value of the constant is compiled code, then ;; recursively disassemble it. (cond ((or (byte-code-function-p arg) - (and (eq (car-safe arg) 'lambda) + (and (consp arg) (functionp arg) (assq 'byte-code arg)) (and (eq (car-safe arg) 'macro) (or (byte-code-function-p (cdr arg)) - (and (eq (car-safe (cdr arg)) 'lambda) + (and (consp (cdr arg)) + (functionp (cdr arg)) (assq 'byte-code (cdr arg)))))) (cond ((byte-code-function-p arg) (insert "<compiled-function>\n")) - ((eq (car-safe arg) 'lambda) + ((functionp arg) (insert "<compiled lambda>")) (t (insert "<compiled macro>\n"))) (disassemble-internal diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 1301b70bb85..56f95111ab8 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-2015 Free Software Foundation, Inc. ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr> ;; Maintainer: Stefan Monnier <monnier@gnu.org> @@ -114,9 +114,12 @@ Optional KEYMAP is the default keymap bound to the mode keymap. BODY contains code to execute each time the mode is enabled or disabled. It is executed after toggling the mode, and before running MODE-hook. Before the actual body code, you can write keyword arguments, i.e. - alternating keywords and values. These following special keywords - are supported (other keywords are passed to `defcustom' if the minor - mode is global): + alternating keywords and values. If you provide BODY, then you must + provide (even if just nil) INIT-VALUE, LIGHTER, and KEYMAP, or provide + at least one keyword argument, or both; otherwise, BODY would be + misinterpreted as the first omitted argument. The following special + keywords are supported (other keywords are passed to `defcustom' if + the minor mode is global): :group GROUP Custom group name to use in all generated `defcustom' forms. Defaults to MODE without the possible trailing \"-mode\". @@ -133,7 +136,7 @@ BODY contains code to execute each time the mode is enabled or disabled. :variable PLACE The location to use instead of the variable MODE to store the state of the mode. This can be simply a different named variable, or a generalized variable. - PLACE can also be of the form \(GET . SET), where GET is + PLACE can also be of the form (GET . SET), where GET is an expression that returns the current state, and SET is a function that takes one argument, the new state, and sets it. If you specify a :variable, this function does @@ -148,17 +151,19 @@ For example, you could write :lighter \" Foo\" :require 'foo :global t :group 'hassle :version \"27.5\" ...BODY CODE...)" (declare (doc-string 2) - (debug (&define name stringp - [&optional [¬ keywordp] sexp - &optional [¬ keywordp] sexp - &optional [¬ keywordp] sexp] - [&rest [keywordp sexp]] - def-body))) + (debug (&define name string-or-null-p + [&optional [¬ keywordp] sexp + &optional [¬ keywordp] sexp + &optional [¬ keywordp] sexp] + [&rest [keywordp sexp]] + def-body)) + (indent 1)) ;; Allow skipping the first three args. (cond ((keywordp init-value) - (setq body `(,init-value ,lighter ,keymap ,@body) + (setq body (if keymap `(,init-value ,lighter ,keymap ,@body) + `(,init-value ,lighter)) init-value nil lighter nil keymap nil)) ((keywordp lighter) (setq body `(,lighter ,keymap ,@body) lighter nil keymap nil)) @@ -175,7 +180,8 @@ For example, you could write (extra-args nil) (extra-keywords nil) (variable nil) ;The PLACE where the state is stored. - (setter nil) ;The function (if any) to set the mode var. + (setter `(setq ,mode)) ;The beginning of the exp to set the mode var. + (getter mode) ;The exp to get the mode value. (modefun mode) ;The minor mode function name we're defining. (require t) (after-hook nil) @@ -190,7 +196,10 @@ For example, you could write (pcase keyw (`:init-value (setq init-value (pop body))) (`:lighter (setq lighter (purecopy (pop body)))) - (`:global (setq globalp (pop body))) + (`:global (setq globalp (pop body)) + (when (and globalp (symbolp mode)) + (setq setter `(setq-default ,mode)) + (setq getter `(default-value ',mode)))) (`:extra-args (setq extra-args (pop body))) (`:set (setq set (list :set (pop body)))) (`:initialize (setq initialize (list :initialize (pop body)))) @@ -203,16 +212,18 @@ For example, you could write (or (symbolp tmp) (functionp tmp)))) ;; PLACE is not of the form (GET . SET). - (setq mode variable) - (setq mode (car variable)) - (setq setter (cdr variable)))) + (progn + (setq setter `(setf ,variable)) + (setq getter variable)) + (setq getter (car variable)) + (setq setter `(funcall #',(cdr variable))))) (`:after-hook (setq after-hook (pop body))) (_ (push keyw extra-keywords) (push (pop body) extra-keywords)))) (setq keymap-sym (if (and keymap (symbolp keymap)) keymap (intern (concat mode-name "-map")))) - (unless set (setq set '(:set 'custom-set-minor-mode))) + (unless set (setq set '(:set #'custom-set-minor-mode))) (unless initialize (setq initialize '(:initialize 'custom-initialize-default))) @@ -267,30 +278,30 @@ the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. ;; repeat-command still does the toggling correctly. (interactive (list (or current-prefix-arg 'toggle))) (let ((,last-message (current-message))) - (,@(if setter `(funcall #',setter) - (list (if (symbolp mode) 'setq 'setf) mode)) + (,@setter (if (eq arg 'toggle) - (not ,mode) + (not ,getter) ;; A nil argument also means ON now. (> (prefix-numeric-value arg) 0))) ,@body ;; The on/off hooks are here for backward compatibility only. - (run-hooks ',hook (if ,mode ',hook-on ',hook-off)) + (run-hooks ',hook (if ,getter ',hook-on ',hook-off)) (if (called-interactively-p 'any) (progn - ,(if (and globalp (symbolp mode)) + ,(if (and globalp (not variable)) `(customize-mark-as-set ',mode)) ;; Avoid overwriting a message shown by the body, ;; but do overwrite previous messages. (unless (and (current-message) (not (equal ,last-message (current-message)))) - (message ,(format "%s %%sabled" pretty-name) - (if ,mode "en" "dis"))))) + (let ((local ,(if globalp "" " in current buffer"))) + (message ,(format "%s %%sabled%%s" pretty-name) + (if ,getter "en" "dis") local))))) ,@(when after-hook `(,after-hook))) (force-mode-line-update) ;; Return the new setting. - ,mode) + ,getter) ;; Autoloading a define-minor-mode autoloads everything ;; up-to-here. @@ -300,7 +311,7 @@ the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. ,(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)) + modefun)) ;; Define the minor-mode keymap. ,(unless (symbolp keymap) ;nil is also a symbol. @@ -311,15 +322,16 @@ No problems result if this variable is not bound. (t (error "Invalid keymap %S" m)))) ,(format "Keymap for `%s'." mode-name))) - ,(if (not (symbolp mode)) - (if (or lighter keymap) - (error ":lighter and :keymap unsupported with mode expression %s" mode)) - `(with-no-warnings - (add-minor-mode ',mode ',lighter - ,(if keymap keymap-sym - `(if (boundp ',keymap-sym) ,keymap-sym)) - nil - ,(unless (eq mode modefun) `',modefun))))))) + ,(let ((modevar (pcase getter (`(default-value ',v) v) (_ getter)))) + (if (not (symbolp modevar)) + (if (or lighter keymap) + (error ":lighter and :keymap unsupported with mode expression %S" getter)) + `(with-no-warnings + (add-minor-mode ',modevar ',lighter + ,(if keymap keymap-sym + `(if (boundp ',keymap-sym) ,keymap-sym)) + nil + ,(unless (eq mode modefun) `',modefun)))))))) ;;; ;;; make global minor mode @@ -399,7 +411,7 @@ otherwise, disable it. If called from Lisp, enable the mode if ARG is omitted or nil. %s is enabled in all buffers where -\`%s' would do it. +`%s' would do it. See `%s' for more information on %s." pretty-name pretty-global-name pretty-name turn-on mode pretty-name) diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index f33ae54bf25..ad2ba6994f2 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-2015 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 ec343eab631..a3e3b567cc4 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-2015 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. @@ -85,7 +85,7 @@ This applies to `eval-defun', `eval-region', `eval-buffer', and You can use the command `edebug-all-defs' to toggle the value of this variable. You may wish to make it local to each buffer with -\(make-local-variable 'edebug-all-defs) in your +\(make-local-variable \\='edebug-all-defs) in your `emacs-lisp-mode-hook'." :type 'boolean :group 'edebug) @@ -411,12 +411,7 @@ Return the result of the last expression in BODY." ;; read is redefined to maybe instrument forms. ;; eval-defun is redefined to check edebug-all-forms and edebug-all-defs. -;; Save the original read function -(defalias 'edebug-original-read - (symbol-function (if (fboundp 'edebug-original-read) - 'edebug-original-read 'read))) - -(defun edebug-read (&optional stream) +(defun edebug--read (orig &optional stream) "Read one Lisp expression as text from STREAM, return as Lisp object. If STREAM is nil, use the value of `standard-input' (which see). STREAM or the value of `standard-input' may be: @@ -434,10 +429,7 @@ the option `edebug-all-forms'." (or stream (setq stream standard-input)) (if (eq stream (current-buffer)) (edebug-read-and-maybe-wrap-form) - (edebug-original-read stream))) - -(or (fboundp 'edebug-original-eval-defun) - (defalias 'edebug-original-eval-defun (symbol-function 'eval-defun))) + (funcall (or orig #'read) stream))) (defvar edebug-result) ; The result of the function call returned by body. @@ -497,7 +489,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 + (prin1 edebug-result) + (let ((str (eval-expression-print-format edebug-result))) + (if str (princ str)))) edebug-result))) @@ -565,16 +560,13 @@ already is one.)" (defun edebug-install-read-eval-functions () (interactive) - ;; Don't install if already installed. - (unless load-read-function - (setq load-read-function 'edebug-read) - (defalias 'eval-defun 'edebug-eval-defun))) + (add-function :around load-read-function #'edebug--read) + (advice-add 'eval-defun :override #'edebug-eval-defun)) (defun edebug-uninstall-read-eval-functions () (interactive) - (setq load-read-function nil) - (defalias 'eval-defun (symbol-function 'edebug-original-eval-defun))) - + (remove-function load-read-function #'edebug--read) + (advice-remove 'eval-defun 'edebug-eval-defun)) ;;; Edebug internal data @@ -608,7 +600,7 @@ list of a symbol.") (defun edebug-get-form-data-entry (pnt &optional end-point) ;; Find the edebug form data entry which is closest to PNT. ;; If END-POINT is supplied, match must be exact. - ;; Return `nil' if none found. + ;; Return nil if none found. (let ((rest edebug-form-data) closest-entry (closest-dist 999999)) ;; Need maxint here. @@ -719,8 +711,8 @@ Maybe clear the markers and delete the symbol's edebug property?" (cond ;; read goes one too far if a (possibly quoted) string or symbol ;; is immediately followed by non-whitespace. - ((eq class 'symbol) (edebug-original-read (current-buffer))) - ((eq class 'string) (edebug-original-read (current-buffer))) + ((eq class 'symbol) (read (current-buffer))) + ((eq class 'string) (read (current-buffer))) ((eq class 'quote) (forward-char 1) (list 'quote (edebug-read-sexp))) ((eq class 'backquote) @@ -728,7 +720,7 @@ Maybe clear the markers and delete the symbol's edebug property?" ((eq class 'comma) (list '\, (edebug-read-sexp))) (t ; anything else, just read it. - (edebug-original-read (current-buffer)))))) + (read (current-buffer)))))) ;;; Offsets for reader @@ -824,14 +816,11 @@ Maybe clear the markers and delete the symbol's edebug property?" (funcall (or (cdr (assq (edebug-next-token-class) edebug-read-alist)) ;; anything else, just read it. - 'edebug-original-read) + #'read) stream)))) -(defun edebug-read-symbol (stream) - (edebug-original-read stream)) - -(defun edebug-read-string (stream) - (edebug-original-read stream)) +(defalias 'edebug-read-symbol #'read) +(defalias 'edebug-read-string #'read) (defun edebug-read-quote (stream) ;; Turn 'thing into (quote thing) @@ -875,7 +864,7 @@ Maybe clear the markers and delete the symbol's edebug property?" ((memq (following-char) '(?: ?B ?O ?X ?b ?o ?x ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?0)) (backward-char 1) - (edebug-original-read stream)) + (read stream)) (t (edebug-syntax-error "Bad char after #")))) (defun edebug-read-list (stream) @@ -1046,16 +1035,15 @@ Maybe clear the markers and delete the symbol's edebug property?" edebug-gate edebug-best-error edebug-error-point - no-match ;; Do this once here instead of several times. (max-lisp-eval-depth (+ 800 max-lisp-eval-depth)) (max-specpdl-size (+ 2000 max-specpdl-size))) - (setq no-match - (catch 'no-match - (setq result (edebug-read-and-maybe-wrap-form1)) - nil)) - (if no-match - (apply 'edebug-syntax-error no-match)) + (let ((no-match + (catch 'no-match + (setq result (edebug-read-and-maybe-wrap-form1)) + nil))) + (if no-match + (apply 'edebug-syntax-error no-match))) result)) @@ -1074,7 +1062,7 @@ Maybe clear the markers and delete the symbol's edebug property?" (if (and (eq 'lparen (edebug-next-token-class)) (eq 'symbol (progn (forward-char 1) (edebug-next-token-class)))) ;; Find out if this is a defining form from first symbol - (setq def-kind (edebug-original-read (current-buffer)) + (setq def-kind (read (current-buffer)) spec (and (symbolp def-kind) (get-edebug-spec def-kind)) defining-form-p (and (listp spec) (eq '&define (car spec))) @@ -1082,7 +1070,7 @@ Maybe clear the markers and delete the symbol's edebug property?" def-name (if (and defining-form-p (eq 'name (car (cdr spec))) (eq 'symbol (edebug-next-token-class))) - (edebug-original-read (current-buffer)))))) + (read (current-buffer)))))) ;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) (cond (defining-form-p @@ -1737,6 +1725,17 @@ expressions; a `progn' form will be returned enclosing these forms." (t (error "Bad spec: %s" specs))))) + ((eq 'vector spec) + (if (vectorp form) + ;; Special case: match a vector with the specs. + (let ((result (edebug-match-sublist + (edebug-new-cursor + form (cdr (edebug-top-offset cursor))) + (cdr specs)))) + (edebug-move-cursor cursor) + (list (apply 'vector result))) + (edebug-no-match cursor "Expected" specs))) + ((listp form) (prog1 (list (edebug-match-sublist @@ -1746,15 +1745,6 @@ expressions; a `progn' form will be returned enclosing these forms." specs)) (edebug-move-cursor cursor))) - ((and (eq 'vector spec) (vectorp form)) - ;; Special case: match a vector with the specs. - (let ((result (edebug-match-sublist - (edebug-new-cursor - form (cdr (edebug-top-offset cursor))) - (cdr specs)))) - (edebug-move-cursor cursor) - (list (apply 'vector result)))) - (t (edebug-no-match cursor "Expected" specs))) ))) @@ -1881,8 +1871,13 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Like body but body is wrapped in edebug-enter form. ;; The body is assumed to be executing inside of the function context. ;; Not to be used otherwise. - (let ((edebug-inside-func t)) - (list (edebug-wrap-def-body (edebug-forms cursor))))) + (let* ((edebug-inside-func t) + (forms (edebug-forms cursor))) + ;; If there's no form, there's nothing to wrap! + ;; This happens to handle bug#20281, tho maybe a better fix would be to + ;; improve the `defun' spec. + (when forms + (list (edebug-wrap-def-body forms))))) ;;;; Edebug Form Specs @@ -1933,11 +1928,11 @@ expressions; a `progn' form will be returned enclosing these forms." [&optional stringp] [&optional ("interactive" interactive)] def-body)) -;; FIXME? Isn't this missing the doc-string? Cf defun. (def-edebug-spec defmacro ;; FIXME: Improve `declare' so we can Edebug gv-expander and ;; gv-setter declarations. - (&define name lambda-list [&optional ("declare" &rest sexp)] def-body)) + (&define name lambda-list [&optional stringp] + [&optional ("declare" &rest sexp)] def-body)) (def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list. @@ -2370,6 +2365,12 @@ MSG is printed after `::::} '." (defalias 'edebug-mark-marker 'mark-marker) (defun edebug--display (value offset-index arg-mode) + ;; edebug--display-1 is too big, we should split it. This function + ;; here was just introduced to avoid making edebug--display-1 + ;; yet a bit deeper. + (save-excursion (edebug--display-1 value offset-index arg-mode))) + +(defun edebug--display-1 (value offset-index arg-mode) (unless (marker-position edebug-def-mark) ;; The buffer holding the source has been killed. ;; Let's at least show a backtrace so the user can figure out @@ -2402,9 +2403,7 @@ MSG is printed after `::::} '." (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?? ) @@ -2454,147 +2453,144 @@ MSG is printed after `::::} '." edebug-function) )) - (setcdr edebug-window-data - (edebug-adjust-window (cdr edebug-window-data))) + ;; 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) - ;; Test if there is input, not including keyboard macros. - (if (input-pending-p) - (progn - (setq edebug-execution-mode 'step - edebug-stop t) - (edebug-stop) - ;; (discard-input) ; is this unfriendly?? - )) - ;; Now display arrow based on mode. - (edebug-overlay-arrow) + (cond + ((eq 'error 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. + + (when (input-pending-p) + (setq edebug-stop t) + (setq edebug-execution-mode 'step) ; for `edebug-overlay-arrow' + (edebug-stop)) - (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 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 + (unwind-protect + (if (or edebug-stop + (memq edebug-execution-mode '(step next)) + (eq arg-mode 'error)) + (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. @@ -2680,12 +2676,6 @@ MSG is printed after `::::} '." (defining-kbd-macro (if edebug-continue-kbd-macro defining-kbd-macro)) - ;; Disable command hooks. This is essential when - ;; a hook function is instrumented - to avoid infinite loop. - ;; This may be more than we need, however. - (pre-command-hook nil) - (post-command-hook nil) - ;; others?? ) @@ -2714,8 +2704,9 @@ MSG is printed after `::::} '." (if (buffer-name edebug-buffer) ; if it still exists (progn (set-buffer edebug-buffer) - (if (memq edebug-execution-mode '(go Go-nonstop)) - (edebug-overlay-arrow)) + (when (memq edebug-execution-mode '(go Go-nonstop)) + (edebug-overlay-arrow) + (sit-for 0)) (edebug-mode -1)) ;; gotta have a buffer to let its buffer local variables be set (get-buffer-create " bogus edebug buffer")) @@ -2725,31 +2716,6 @@ MSG is printed after `::::} '." ;;; Display related functions -(defun edebug-adjust-window (old-start) - ;; If pos is not visible, adjust current window to fit following context. - ;; (message "window: %s old-start: %s window-start: %s pos: %s" - ;; (selected-window) old-start (window-start) (point)) (sit-for 5) - (if (not (pos-visible-in-window-p)) - (progn - ;; First try old-start - (if old-start - (set-window-start (selected-window) old-start)) - (if (not (pos-visible-in-window-p)) - (progn - ;; (message "resetting window start") (sit-for 2) - (set-window-start - (selected-window) - (save-excursion - (forward-line - (if (< (point) (window-start)) -1 ; one line before if in back - (- (/ (window-height) 2)) ; center the line moving forward - )) - (beginning-of-line) - (point))))))) - (window-start)) - - - (defconst edebug-arrow-alist '((Continue-fast . "=") (Trace-fast . "-") @@ -2758,7 +2724,7 @@ MSG is printed after `::::} '." (step . "=>") (next . "=>") (go . "<>") - (Go-nonstop . "..") ; not used + (Go-nonstop . "..") ) "Association list of arrows for each edebug mode.") @@ -3196,15 +3162,15 @@ Do this when stopped before the form or it will be too late. One side effect of using this command is that the next time the function or macro is called, Edebug will be called there as well." (interactive) - (if (not (looking-at "\(")) + (if (not (looking-at "(")) (error "You must be before a list form") (let ((func (save-excursion (down-list 1) - (if (looking-at "\(") + (if (looking-at "(") (edebug--form-data-name (edebug-get-form-data-entry (point))) - (edebug-original-read (current-buffer)))))) + (read (current-buffer)))))) (edebug-instrument-function func)))) @@ -3232,25 +3198,14 @@ canceled the first time the function is entered." (put function 'edebug-on-entry nil)) -(if (not (fboundp 'edebug-original-debug-on-entry)) - (fset 'edebug-original-debug-on-entry (symbol-function 'debug-on-entry))) -'(fset 'debug-on-entry 'edebug-debug-on-entry) ;; Should we do this? +'(advice-add 'debug-on-entry :around 'edebug--debug-on-entry) ;; Should we do this? ;; Also need edebug-cancel-debug-on-entry -'(defun edebug-debug-on-entry (function) - "Request FUNCTION to invoke debugger each time it is called. -If the user continues, FUNCTION's execution proceeds. -Works by modifying the definition of FUNCTION, -which must be written in Lisp, not predefined. -Use `cancel-debug-on-entry' to cancel the effect of this command. -Redefining FUNCTION also does that. - -This version is from Edebug. If the function is instrumented for -Edebug, it calls `edebug-on-entry'." - (interactive "aDebug on entry (to function): ") +'(defun edebug--debug-on-entry (orig function) + "If the function is instrumented for Edebug, call `edebug-on-entry'." (let ((func-data (get function 'edebug))) (if (or (null func-data) (markerp func-data)) - (edebug-original-debug-on-entry function) + (funcall orig function) (edebug-on-entry function)))) @@ -3261,57 +3216,45 @@ This is useful for exiting even if `unwind-protect' code may be executed." (setq edebug-execution-mode 'Go-nonstop) (top-level)) - ;;(defun edebug-exit-out () ;; "Go until the current function exits." ;; (interactive) ;; (edebug-set-mode 'exiting "Exit...")) - -;;; The following initial mode setting definitions are not used yet. - -'(defconst edebug-initial-mode-alist - '((edebug-Continue-fast . Continue-fast) - (edebug-Trace-fast . Trace-fast) - (edebug-continue . continue) - (edebug-trace . trace) - (edebug-go . go) - (edebug-step-through . step) - (edebug-Go-nonstop . Go-nonstop) - ) +(defconst edebug-initial-mode-alist + '((edebug-step-mode . step) + (edebug-next-mode . next) + (edebug-trace-mode . trace) + (edebug-Trace-fast-mode . Trace-fast) + (edebug-go-mode . go) + (edebug-continue-mode . continue) + (edebug-Continue-fast-mode . Continue-fast) + (edebug-Go-nonstop-mode . Go-nonstop)) "Association list between commands and the modes they set.") +(defvar edebug-mode-map) ; will be defined fully later. -'(defun edebug-set-initial-mode () - "Ask for the initial mode of the enclosing function. +(defun edebug-set-initial-mode () + "Set the initial execution mode of Edebug. The mode is requested via the key that would be used to set the mode in edebug-mode." (interactive) - (let* ((this-function (edebug-which-function)) - (keymap (if (eq edebug-mode-map (current-local-map)) - edebug-mode-map)) - (old-mode (or (get this-function 'edebug-initial-mode) - edebug-initial-mode)) + (let* ((old-mode edebug-initial-mode) (key (read-key-sequence (format - "Change initial edebug mode for %s from %s (%s) to (enter key): " - this-function - old-mode - (where-is-internal - (car (rassq old-mode edebug-initial-mode-alist)) - keymap 'firstonly - )))) - (mode (cdr (assq (key-binding key) edebug-initial-mode-alist))) - ) - (if (and mode - (or (get this-function 'edebug-initial-mode) - (not (eq mode edebug-initial-mode)))) + "Change initial edebug mode from %s (%c) to (enter key): " + old-mode + (aref (where-is-internal + (car (rassq old-mode edebug-initial-mode-alist)) + edebug-mode-map 'firstonly) + 0)))) + (mode (cdr (assq (lookup-key edebug-mode-map key) + edebug-initial-mode-alist)))) + (if mode (progn - (put this-function 'edebug-initial-mode mode) - (message "Initial mode for %s is now: %s" - this-function mode)) - (error "Key must map to one of the mode changing commands") - ))) + (setq edebug-initial-mode mode) + (message "Edebug's initial mode is now: %s" mode)) + (error "Key must map to one of the mode changing commands")))) ;;; Evaluation of expressions @@ -3337,6 +3280,9 @@ Return the result of the last expression." ;; Restore outside context. (setq-default cursor-in-non-selected-windows edebug-outside-d-c-i-n-s-w) (unwind-protect + ;; FIXME: This restoring of edebug-outside-buffer and + ;; edebug-outside-point is redundant now that backtrace-eval does it + ;; for us. (with-current-buffer edebug-outside-buffer ; of edebug-buffer (goto-char edebug-outside-point) (if (marker-buffer (edebug-mark-marker)) @@ -3394,9 +3340,7 @@ Return the result of the last expression." (print-level (or edebug-print-level print-level)) (print-circle (or edebug-print-circle print-circle)) (print-readably nil)) ; lemacs uses this. - (condition-case nil - (edebug-prin1-to-string value) - (error "#Apparently circular structure#")))) + (edebug-prin1-to-string value))) (defun edebug-compute-previous-result (previous-value) (if edebug-unwrap-results @@ -3417,7 +3361,7 @@ Return the result of the last expression." (defalias 'edebug-prin1 'prin1) (defalias 'edebug-print 'print) (defalias 'edebug-prin1-to-string 'prin1-to-string) -(defalias 'edebug-format 'format) +(defalias 'edebug-format 'format-message) (defalias 'edebug-message 'message) (defun edebug-eval-expression (expr) @@ -3469,7 +3413,9 @@ be installed in `emacs-lisp-mode-map'.") (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode) (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode) - (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where)) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where) + ;; The following isn't a GUD binding. + (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" 'edebug-set-initial-mode)) (defvar edebug-mode-map (let ((map (copy-keymap emacs-lisp-mode-map))) @@ -3834,10 +3780,10 @@ Otherwise call `debug' normally." (if t (progn ;; Delete interspersed edebug internals. - (while (re-search-forward "^ \(?edebug" nil t) + (while (re-search-forward "^ (?edebug" nil t) (beginning-of-line) (cond - ((looking-at "^ \(edebug-after") + ((looking-at "^ (edebug-after") ;; Previous lines may contain code, so just delete this line. (setq last-ok-point (point)) (forward-line 1) @@ -4131,9 +4077,8 @@ With prefix argument, make it a temporary breakpoint." 'edebug--called-interactively-skip) (remove-hook 'cl-read-load-hooks 'edebug--require-cl-read) (edebug-uninstall-read-eval-functions) - ;; continue standard unloading + ;; Continue standard unloading. nil) (provide 'edebug) - ;;; edebug.el ends here diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 21190446624..400bdb95c06 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. +;;; eieio-base.el --- Base classes for EIEIO. -*- lexical-binding:t -*- -;;; Copyright (C) 2000-2002, 2004-2005, 2007-2013 Free Software +;;; Copyright (C) 2000-2002, 2004-2005, 2007-2015 Free Software ;;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -31,7 +31,7 @@ ;;; Code: (require 'eieio) -(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! +(eval-when-compile (require 'cl-lib)) ;;; eieio-instance-inheritor ;; @@ -40,7 +40,7 @@ ;; error if a slot is unbound. (defclass eieio-instance-inheritor () ((parent-instance :initarg :parent-instance - :type eieio-instance-inheritor-child + :type eieio-instance-inheritor :documentation "The parent of this instance. If a slot of this class is referenced, and is unbound, then the parent @@ -52,7 +52,8 @@ a parent instance. When a slot in the child is referenced, and has not been set, use values from the parent." :abstract t) -(defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn) +(cl-defmethod slot-unbound ((object eieio-instance-inheritor) + _class slot-name _fn) "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal. SLOT-NAME is the offending slot. FN is the function signaling the error." (if (slot-boundp object 'parent-instance) @@ -60,31 +61,16 @@ SLOT-NAME is the offending slot. FN is the function signaling the error." ;; method if the parent instance's slot is unbound. (eieio-oref (oref object parent-instance) slot-name) ;; Throw the regular signal. - (call-next-method))) + (cl-call-next-method))) -(defmethod clone ((obj eieio-instance-inheritor) &rest params) +(cl-defmethod clone ((obj eieio-instance-inheritor) &rest _params) "Clone OBJ, initializing `:parent' to OBJ. All slots are unbound, except those initialized with PARAMS." - (let ((nobj (make-vector (length obj) eieio-unbound)) - (nm (eieio--object-name obj)) - (passname (and params (stringp (car params)))) - (num 1)) - (aset nobj 0 'object) - (setf (eieio--object-class nobj) (eieio--object-class obj)) - ;; The following was copied from the default clone. - (if (not passname) - (save-match-data - (if (string-match "-\\([0-9]+\\)" nm) - (setq num (1+ (string-to-number (match-string 1 nm))) - nm (substring nm 0 (match-beginning 0)))) - (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num)))) - (setf (eieio--object-name nobj) (car params))) - ;; Now initialize from params. - (if params (shared-initialize nobj (if passname (cdr params) params))) + (let ((nobj (cl-call-next-method))) (oset nobj parent-instance obj) nobj)) -(defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor) +(cl-defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor) slot) "Return non-nil if the instance inheritor OBJECT's SLOT is bound. See `slot-boundp' for details on binding slots. @@ -117,8 +103,8 @@ Inheritors from this class must overload `tracking-symbol' which is a variable symbol used to store a list of all instances." :abstract t) -(defmethod initialize-instance :AFTER ((this eieio-instance-tracker) - &rest slots) +(cl-defmethod initialize-instance :after ((this eieio-instance-tracker) + &rest _slots) "Make sure THIS is in our master list of this class. Optional argument SLOTS are the initialization arguments." ;; Theoretically, this is never called twice for a given instance. @@ -126,7 +112,7 @@ Optional argument SLOTS are the initialization arguments." (if (not (memq this (symbol-value sym))) (set sym (append (symbol-value sym) (list this)))))) -(defmethod delete-instance ((this eieio-instance-tracker)) +(cl-defmethod delete-instance ((this eieio-instance-tracker)) "Remove THIS from the master list of this class." (set (oref this tracking-symbol) (delq this (symbol-value (oref this tracking-symbol))))) @@ -154,7 +140,7 @@ Multiple calls to `make-instance' will return this object.")) A singleton is a class which will only ever have one instance." :abstract t) -(defmethod constructor :STATIC ((class eieio-singleton) name &rest slots) +(cl-defmethod make-instance ((class (subclass eieio-singleton)) &rest _slots) "Constructor for singleton CLASS. NAME and SLOTS initialize the new object. This constructor guarantees that no matter how many you request, @@ -163,7 +149,7 @@ only one object ever exists." ;; with class allocated slots or default values. (let ((old (oref-default class singleton))) (if (eq old eieio-unbound) - (oset-default class singleton (call-next-method)) + (oset-default class singleton (cl-call-next-method)) old))) @@ -212,7 +198,7 @@ object. For this reason, only slots which do not have an `:initarg' specified will not be saved." :abstract t) -(defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt +(cl-defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt &optional name) "Prepare to save THIS. Use in an `interactive' statement. Query user for file name with PROMPT if THIS does not yet specify @@ -233,7 +219,7 @@ for CLASS. Optional ALLOW-SUBCLASS says that it is ok for being pedantic." (unless class (message "Unsafe call to `eieio-persistent-read'.")) - (when class (eieio--check-type class-p class)) + (when class (cl-check-type class class)) (let ((ret nil) (buffstr nil)) (unwind-protect @@ -268,31 +254,34 @@ malicious code. Note: This function recurses when a slot of :type of some object is identified, and needing more object creation." - (let ((objclass (nth 0 inputlist)) - (objname (nth 1 inputlist)) - (slots (nthcdr 2 inputlist)) - (createslots nil)) - - ;; If OBJCLASS is an eieio autoload object, then we need to load it. - (eieio-class-un-autoload objclass) + (let* ((objclass (nth 0 inputlist)) + ;; (objname (nth 1 inputlist)) + (slots (nthcdr 2 inputlist)) + (createslots nil) + (class + (progn + ;; If OBJCLASS is an eieio autoload object, then we need to + ;; load it. + (eieio-class-un-autoload objclass) + (eieio--class-object objclass)))) (while slots - (let ((name (car slots)) + (let ((initarg (car slots)) (value (car (cdr slots)))) ;; Make sure that the value proposed for SLOT is valid. ;; In addition, strip out quotes, list functions, and update ;; object constructors as needed. (setq value (eieio-persistent-validate/fix-slot-value - objclass name value)) + class (eieio--initarg-to-attribute class initarg) value)) - (push name createslots) + (push initarg createslots) (push value createslots) ) (setq slots (cdr (cdr slots)))) - (apply 'make-instance objclass objname (nreverse createslots)) + (apply #'make-instance objclass (nreverse createslots)) ;;(eval inputlist) )) @@ -304,15 +293,12 @@ constructor functions are considered valid. Second, any text properties will be stripped from strings." (cond ((consp proposed-value) ;; Lists with something in them need special treatment. - (let ((slot-idx (eieio-slot-name-index class nil slot)) - (type nil) - (classtype nil)) - (setq slot-idx (- slot-idx 3)) - (setq type (aref (eieio--class-public-type (class-v class)) - slot-idx)) - - (setq classtype (eieio-persistent-slot-type-is-class-p - type)) + (let* ((slot-idx (- (eieio--slot-name-index class slot) + (eval-when-compile + (length (cl-struct-slot-info 'eieio--object))))) + (type (cl--slot-descriptor-type (aref (eieio--class-slots class) + slot-idx))) + (classtype (eieio-persistent-slot-type-is-class-p type))) (cond ((eq (car proposed-value) 'quote) (car (cdr proposed-value))) @@ -345,8 +331,8 @@ Second, any text properties will be stripped from strings." (unless (and ;; Do we have a type? (consp classtype) (class-p (car classtype))) - (error "In save file, list of object constructors found, but no :type specified for slot %S" - slot)) + (error "In save file, list of object constructors found, but no :type specified for slot %S of type %S" + slot classtype)) ;; We have a predicate, but it doesn't satisfy the predicate? (dolist (PV (cdr proposed-value)) @@ -374,31 +360,49 @@ Second, any text properties will be stripped from strings." ) (defun eieio-persistent-slot-type-is-class-p (type) - "Return the class refered to in TYPE. + "Return the class referred to in TYPE. If no class is referenced there, then return nil." (cond ((class-p type) ;; If the type is a class, then return it. type) - - ((and (symbolp type) (string-match "-child$" (symbol-name type)) + ((and (eq 'list-of (car-safe type)) (class-p (cadr type))) + ;; If it is the type of a list of a class, then return that class and + ;; the type. + (cons (cadr type) type)) + + ((and (symbolp type) (get type 'cl-deftype-handler)) + ;; Macro-expand the type according to cl-deftype definitions. + (eieio-persistent-slot-type-is-class-p + (funcall (get type 'cl-deftype-handler)))) + + ;; FIXME: foo-child should not be a valid type! + ((and (symbolp type) (string-match "-child\\'" (symbol-name type)) (class-p (intern-soft (substring (symbol-name type) 0 (match-beginning 0))))) + (unless eieio-backward-compatibility + (error "Use of bogus %S type instead of %S" + type (intern-soft (substring (symbol-name type) 0 + (match-beginning 0))))) ;; If it is the predicate ending with -child, then return ;; that class. Unfortunately, in EIEIO, typep of just the ;; class is the same as if we used -child, so no further work needed. (intern-soft (substring (symbol-name type) 0 (match-beginning 0)))) - - ((and (symbolp type) (string-match "-list$" (symbol-name type)) + ;; FIXME: foo-list should not be a valid type! + ((and (symbolp type) (string-match "-list\\'" (symbol-name type)) (class-p (intern-soft (substring (symbol-name type) 0 (match-beginning 0))))) + (unless eieio-backward-compatibility + (error "Use of bogus %S type instead of (list-of %S)" + type (intern-soft (substring (symbol-name type) 0 + (match-beginning 0))))) ;; If it is the predicate ending with -list, then return ;; that class and the predicate to use. (cons (intern-soft (substring (symbol-name type) 0 (match-beginning 0))) type)) - ((and (consp type) (eq (car type) 'or)) + ((eq (car-safe type) 'or) ;; If type is a list, and is an or, it is possibly something ;; like (or null myclass), so check for that. (let ((ans nil)) @@ -411,85 +415,89 @@ If no class is referenced there, then return nil." ;; No match, not a class. nil))) -(defmethod object-write ((this eieio-persistent) &optional comment) +(cl-defmethod object-write ((this eieio-persistent) &optional comment) "Write persistent object THIS out to the current stream. Optional argument COMMENT is a header line comment." - (call-next-method this (or comment (oref this file-header-line)))) + (cl-call-next-method this (or comment (oref this file-header-line)))) -(defmethod eieio-persistent-path-relative ((this eieio-persistent) file) +(cl-defmethod eieio-persistent-path-relative ((this eieio-persistent) file) "For object THIS, make absolute file name FILE relative." (file-relative-name (expand-file-name file) (file-name-directory (oref this file)))) -(defmethod eieio-persistent-save ((this eieio-persistent) &optional file) +(cl-defmethod eieio-persistent-save ((this eieio-persistent) &optional file) "Save persistent object THIS to disk. Optional argument FILE overrides the file name specified in the object instance." - (save-excursion - (let ((b (set-buffer (get-buffer-create " *tmp object write*"))) - (default-directory (file-name-directory (oref this file))) - (cfn (oref this file))) - (unwind-protect - (save-excursion - (erase-buffer) - (let ((standard-output (current-buffer))) - (oset this file - (if file - (eieio-persistent-path-relative this file) - (file-name-nondirectory cfn))) - (object-write this (oref this file-header-line))) - (let ((backup-inhibited (not (oref this do-backups))) - (cs (car (find-coding-systems-region - (point-min) (point-max))))) - (unless (eq cs 'undecided) - (setq buffer-file-coding-system cs)) - ;; Old way - write file. Leaves message behind. - ;;(write-file cfn nil) - - ;; New way - Avoid the vast quantities of error checking - ;; just so I can get at the special flags that disable - ;; displaying random messages. - (write-region (point-min) (point-max) - cfn nil 1) - )) - ;; Restore :file, and kill the tmp buffer - (oset this file cfn) - (setq buffer-file-name nil) - (kill-buffer b))))) + (when file (setq file (expand-file-name file))) + (with-temp-buffer + (let* ((cfn (or file (oref this file))) + (default-directory (file-name-directory cfn))) + (cl-letf ((standard-output (current-buffer)) + ((oref this file) ;FIXME: Why change it? + (if file + ;; FIXME: Makes a name relative to (oref this file), + ;; whereas I think it should be relative to cfn. + (eieio-persistent-path-relative this file) + (file-name-nondirectory cfn)))) + (object-write this (oref this file-header-line))) + (let ((backup-inhibited (not (oref this do-backups))) + (coding-system-for-write 'utf-8-emacs)) + ;; Old way - write file. Leaves message behind. + ;;(write-file cfn nil) + + ;; New way - Avoid the vast quantities of error checking + ;; just so I can get at the special flags that disable + ;; displaying random messages. + (write-region (point-min) (point-max) cfn nil 1) + )))) ;; Notes on the persistent object: ;; It should also set up some hooks to help it keep itself up to date. ;;; Named object -;; -;; Named objects use the objects `name' as a slot, and that slot -;; is accessed with the `object-name' symbol. (defclass eieio-named () - () - "Object with a name. -Name storage already occurs in an object. This object provides get/set -access to it." + ((object-name :initarg :object-name :initform nil)) + "Object with a name." :abstract t) -(defmethod slot-missing ((obj eieio-named) - slot-name operation &optional new-value) - "Called when a non-existent slot is accessed. -For variable `eieio-named', provide an imaginary `object-name' slot. -Argument OBJ is the named object. -Argument SLOT-NAME is the slot that was attempted to be accessed. -OPERATION is the type of access, such as `oref' or `oset'. -NEW-VALUE is the value that was being set into SLOT if OPERATION were -a set type." - (if (memq slot-name '(object-name :object-name)) - (cond ((eq operation 'oset) - (if (not (stringp new-value)) - (signal 'invalid-slot-type - (list obj slot-name 'string new-value))) - (eieio-object-set-name-string obj new-value)) - (t (eieio-object-name-string obj))) - (call-next-method))) +(cl-defmethod eieio-object-name-string ((obj eieio-named)) + "Return a string which is OBJ's name." + (or (slot-value obj 'object-name) + (symbol-name (eieio-object-class obj)))) + +(cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) + "Set the string which is OBJ's NAME." + (cl-check-type name string) + (eieio-oset obj 'object-name name)) + +(cl-defmethod clone ((obj eieio-named) &rest params) + "Clone OBJ, initializing `:parent' to OBJ. +All slots are unbound, except those initialized with PARAMS." + (let* ((newname (and (stringp (car params)) (pop params))) + (nobj (apply #'cl-call-next-method obj params)) + (nm (slot-value obj 'object-name))) + (eieio-oset obj 'object-name + (or newname + (save-match-data + (if (and nm (string-match "-\\([0-9]+\\)" nm)) + (let ((num (1+ (string-to-number + (match-string 1 nm))))) + (concat (substring nm 0 (match-beginning 0)) + "-" (int-to-string num))) + (concat nm "-1"))))) + nobj)) + +(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args) + (if (not (stringp (car args))) + (cl-call-next-method) + (funcall (if eieio-backward-compatibility #'ignore #'message) + "Obsolete: name passed without :object-name to %S constructor" + class) + (apply #'cl-call-next-method class :object-name args))) + (provide 'eieio-base) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el new file mode 100644 index 00000000000..638c475ef2b --- /dev/null +++ b/lisp/emacs-lisp/eieio-compat.el @@ -0,0 +1,272 @@ +;;; eieio-compat.el --- Compatibility with Older EIEIO versions -*- lexical-binding:t -*- + +;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; 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: + +;; Backward compatibility definition of old EIEIO functions in +;; terms of newer equivalent. + +;; The main elements are the old EIEIO `defmethod' and `defgeneric' which are +;; now implemented on top of cl-generic. The differences we have to +;; accommodate are: +;; - EIEIO's :static methods (turned into a new `eieio--static' specializer). +;; - EIEIO's support for `call-next-method' and `next-method-p' instead of +;; `cl-next-method-p' and `cl-call-next-method' (simple matter of renaming). +;; - Different errors are signaled. +;; - EIEIO's defgeneric does not reset the function. +;; - EIEIO's no-next-method and no-applicable-method can't be aliases of +;; cl-generic's namesakes since they have different calling conventions, +;; which means that packages that (defmethod no-next-method ..) don't work. +;; - EIEIO's `call-next-method' and `next-method-p' had dynamic scope whereas +;; cl-generic's `cl-next-method-p' and `cl-call-next-method' are lexically +;; scoped. + +;;; Code: + +(require 'eieio-core) +(require 'cl-generic) + +(put 'eieio--defalias 'byte-hunk-handler + #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) +;;;###autoload +(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." + (cl-assert (not (symbolp body))) + (while (and (fboundp name) (symbolp (symbol-function name))) + ;; Follow aliases, so methods applied to obsolete aliases still work. + (setq name (symbol-function name))) + (unless (and (fboundp name) + (eq (symbol-function name) body)) + (defalias name body))) + +;;;###autoload +(defmacro defgeneric (method args &optional doc-string) + "Create a generic function METHOD. +DOC-STRING is the base documentation for this class. A generic +function has no body, as its purpose is to decide which method body +is appropriate to use. Uses `defmethod' to create methods, and calls +`defgeneric' for you. With this implementation the ARGS are +currently ignored. You can use `defgeneric' to apply specialized +top level documentation to a method." + (declare (doc-string 3) (obsolete cl-defgeneric "25.1")) + `(eieio--defalias ',method + (eieio--defgeneric-init-form + ',method + ,(if doc-string (help-add-fundoc-usage doc-string args))))) + +;;;###autoload +(defmacro defmethod (method &rest args) + "Create a new METHOD through `defgeneric' with ARGS. + +The optional second argument KEY is a specifier that +modifies how the method is called, including: + :before - Method will be called before the :primary + :primary - The default if not specified + :after - Method will be called after the :primary + :static - First arg could be an object or class +The next argument is the ARGLIST. The ARGLIST specifies the arguments +to the method as with `defun'. The first argument can have a type +specifier, such as: + ((VARNAME CLASS) ARG2 ...) +where VARNAME is the name of the local variable for the method being +created. The CLASS is a class symbol for a class made with `defclass'. +A DOCSTRING comes after the ARGLIST, and is optional. +All the rest of the args are the BODY of the method. A method will +return the value of the last form in the BODY. + +Summary: + + (defmethod mymethod [:before | :primary | :after | :static] + ((typearg class-name) arg2 &optional opt &rest rest) + \"doc-string\" + body)" + (declare (doc-string 3) (obsolete cl-defmethod "25.1") + (debug + (&define ; this means we are defining something + [&or name ("setf" :name setf name)] + ;; ^^ This is the methods symbol + [ &optional symbolp ] ; this is key :before etc + list ; arguments + [ &optional stringp ] ; documentation string + def-body ; part to be debugged + ))) + (let* ((key (if (keywordp (car args)) (pop args))) + (params (car args)) + (arg1 (car params)) + (fargs (if (consp arg1) + (cons (car arg1) (cdr params)) + params)) + (class (if (consp arg1) (nth 1 arg1))) + (code `(lambda ,fargs ,@(cdr args)))) + `(progn + ;; Make sure there is a generic and the byte-compiler sees it. + (defgeneric ,method ,args) + (eieio--defmethod ',method ',key ',class #',code)))) + +(defun eieio--generic-static-symbol-specializers (tag &rest _) + (cl-assert (or (null tag) (eieio--class-p tag))) + (when (eieio--class-p tag) + (let ((superclasses (eieio--generic-subclass-specializers tag)) + (specializers ())) + (dolist (superclass superclasses) + (push superclass specializers) + (push `(eieio--static ,(cadr superclass)) specializers)) + (nreverse specializers)))) + +(cl-generic-define-generalizer eieio--generic-static-symbol-generalizer + ;; Give it a slightly higher priority than `subclass' so that the + ;; interleaved list comes before subclass's non-interleaved list. + 61 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name))) + #'eieio--generic-static-symbol-specializers) +(cl-generic-define-generalizer eieio--generic-static-object-generalizer + ;; Give it a slightly higher priority than `class' so that the + ;; interleaved list comes before the class's non-interleaved list. + 51 #'cl--generic-struct-tag + (lambda (tag _targets) + (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag)) + (eieio--class-p tag) + (let ((superclasses (eieio--class-precedence-list tag)) + (specializers ())) + (dolist (superclass superclasses) + (setq superclass (eieio--class-name superclass)) + (push superclass specializers) + (push `(eieio--static ,superclass) specializers)) + (nreverse specializers))))) + +(cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static))) + (list eieio--generic-static-symbol-generalizer + eieio--generic-static-object-generalizer)) + +;;;###autoload +(defun eieio--defgeneric-init-form (method doc-string) + (if doc-string (put method 'function-documentation doc-string)) + (if (memq method '(no-next-method no-applicable-method)) + (symbol-function method) + (let ((generic (cl-generic-ensure-function method))) + (symbol-function (cl--generic-name generic))))) + +;;;###autoload +(defun eieio--defmethod (method kind argclass code) + (setq kind (intern (downcase (symbol-name kind)))) + (let* ((specializer (if (not (eq kind :static)) + (or argclass t) + (setq kind nil) + `(eieio--static ,argclass))) + (uses-cnm (not (memq kind '(:before :after)))) + (specializers `((arg ,specializer))) + (code + ;; Backward compatibility for `no-next-method' and + ;; `no-applicable-method', which have slightly different calling + ;; convention than their cl-generic counterpart. + (pcase method + (`no-next-method + (setq method 'cl-no-next-method) + (setq specializers `(generic method ,@specializers)) + (lambda (_generic _method &rest args) (apply code args))) + (`no-applicable-method + (setq method 'cl-no-applicable-method) + (setq specializers `(generic ,@specializers)) + (lambda (generic arg &rest args) (apply code arg generic args))) + (_ code)))) + (cl-generic-define-method + method (unless (memq kind '(nil :primary)) (list kind)) + specializers uses-cnm + (if uses-cnm + (let* ((docstring (documentation code 'raw)) + (args (help-function-arglist code 'preserve-names)) + (doc-only (if docstring + (let ((split (help-split-fundoc docstring nil))) + (if split (cdr split) docstring))))) + (lambda (cnm &rest args) + (:documentation + (help-add-fundoc-usage doc-only (cons 'cl-cnm args))) + (cl-letf (((symbol-function 'call-next-method) cnm) + ((symbol-function 'next-method-p) + (lambda () (cl--generic-isnot-nnm-p cnm)))) + (apply code args)))) + code)) + ;; The old EIEIO code did not signal an error when there are methods + ;; applicable but only of the before/after kind. So if we add a :before + ;; or :after, make sure there's a matching dummy primary. + (when (and (memq kind '(:before :after)) + ;; FIXME: Use `cl-find-method'? + (not (cl-find-method method () + (mapcar (lambda (arg) + (if (consp arg) (nth 1 arg) t)) + specializers)))) + (cl-generic-define-method method () specializers t + (lambda (cnm &rest args) + (if (cl--generic-isnot-nnm-p cnm) + (apply cnm args))))) + method)) + +;; Compatibility with code which tries to catch `no-method-definition' errors. +(push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions)) + +(defun generic-p (fname) (not (null (cl--generic fname)))) + +(defun no-next-method (&rest args) + (declare (obsolete cl-no-next-method "25.1")) + (apply #'cl-no-next-method 'unknown nil args)) + +(defun no-applicable-method (object method &rest args) + (declare (obsolete cl-no-applicable-method "25.1")) + (apply #'cl-no-applicable-method method object args)) + +(define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1") +(defun next-method-p () + (declare (obsolete cl-next-method-p "25.1")) + ;; EIEIO's `next-method-p' just returned nil when called in an + ;; invalid context. + (message "next-method-p called outside of a primary or around method") + nil) + +;;;###autoload +(defun eieio-defmethod (method args) + "Obsolete work part of an old version of the `defmethod' macro." + (declare (obsolete cl-defmethod "24.1")) + (eval `(defmethod ,method ,@args)) + method) + +;;;###autoload +(defun eieio-defgeneric (method doc-string) + "Obsolete work part of an old version of the `defgeneric' macro." + (declare (obsolete cl-defgeneric "24.1")) + (eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string)))) + ;; Return the method + 'method) + +;;;###autoload +(defun eieio-defclass (cname superclasses slots options) + (declare (obsolete eieio-defclass-internal "25.1")) + (eval `(defclass ,cname ,superclasses ,slots ,@options))) + + +;; Local Variables: +;; generated-autoload-file: "eieio-core.el" +;; End: + +(provide 'eieio-compat) + +;;; eieio-compat.el ends here diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index da475638bb7..7011a30656b 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -1,6 +1,6 @@ -;;; eieio-core.el --- Core implementation for eieio +;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*- -;; Copyright (C) 1995-1996, 1998-2013 Free Software Foundation, Inc. +;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 1.4 @@ -31,31 +31,8 @@ ;;; 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))) +(require 'cl-lib) +(require 'pcase) ;;; ;; A few functions that are better in the official EIEIO src, but @@ -63,6 +40,8 @@ definition is the same (`eq') as the old one." (declare-function slot-unbound "eieio") (declare-function slot-missing "eieio") (declare-function child-of-class-p "eieio") +(declare-function same-class-p "eieio") +(declare-function object-of-class-p "eieio") ;;; @@ -85,8 +64,12 @@ 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.") +(defvar eieio-backward-compatibility t + "If nil, drop support for some behaviors of older versions of EIEIO. +Currently under control of this var: +- Define every class as a var whose value is the class symbol. +- Define <class>-child-p and <class>-list-p predicates. +- Allow object names in constructors.") (defconst eieio-unbound (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) @@ -98,237 +81,122 @@ default setting for optimization purposes.") ;; 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. +(progn + ;; Arrange for field access not to bother checking if the access is indeed + ;; made to an eieio--class object. + (cl-declaim (optimize (safety 0))) + +(cl-defstruct (eieio--class + (:constructor nil) + (:constructor eieio--class-make (name)) + (:include cl--class) + (:copier nil)) + children + initarg-tuples ;; initarg tuples list + (class-slots nil :type eieio--slot) + 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 option + ; Stored outright without modifications or stripping + ) + ;; Set it back to the default value. + (cl-declaim (optimize (safety 1)))) -(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)) +(cl-defstruct (eieio--object + (:type vector) ;We manage our own tagging system. + (:constructor nil) + (:copier nil)) + ;; `class-tag' holds a symbol, which is not the class name, but is instead + ;; properly prefixed as an internal EIEIO thingy and which holds the class + ;; object/struct in its `symbol-value' slot. + class-tag) -(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) +(eval-when-compile + (defconst eieio--object-num-slots + (length (cl-struct-slot-info 'eieio--object)))) -;;; -;; 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. - )) +(defsubst eieio--object-class (obj) + (symbol-value (eieio--object-class-tag obj))) ;;; 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))) + +(require 'cl-macs) ;For cl--find-class. + +(defsubst eieio--class-object (class) + "Return the class object." + (if (symbolp class) + ;; Keep the symbol if class-v is nil, for better error messages. + (or (cl--find-class class) class) + class)) + +(defun class-p (x) + "Return non-nil if X is a valid class vector. +X can also be is a symbol." + (eieio--class-p (if (symbolp x) (cl--find-class x) x))) + +(defun eieio--class-print-name (class) + "Return a printed representation of CLASS." + (format "#<class %s>" (eieio-class-name class))) + +(defun eieio-class-name (class) + "Return a Lisp like symbol name for CLASS." + (setq class (eieio--class-object class)) + (cl-check-type class eieio--class) + (eieio--class-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) +(defalias 'eieio--class-constructor #'identity + "Return the symbol representing the constructor of CLASS.") + +(defmacro eieio--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) +(defsubst eieio--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)) + (eieio--class-option-assoc (eieio--class-options class) option)) -(defmacro eieio-object-p (obj) +(defun 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) + (and (vectorp obj) + (> (length obj) 0) + (let ((tag (eieio--object-class-tag obj))) + (and (symbolp tag) + ;; (eq (symbol-function tag) :quick-object-witness-check) + (boundp tag) + (eieio--class-p (symbol-value tag)))))) + +(define-obsolete-function-alias 'object-p 'eieio-object-p "25.1") + +(defun class-abstract-p (class) "Return non-nil if CLASS is abstract. Abstract classes cannot be instantiated." - `(class-option ,class :abstract)) + (eieio--class-option (cl--find-class class) :abstract)) -(defmacro class-method-invocation-order (class) +(defsubst eieio--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)) + (or (eieio--class-option class :method-invocation-order) + :breadth-first)) ;;; ;; Class Creation -(defvar eieio-defclass-autoload-map (make-vector 7 nil) +(defvar eieio-defclass-autoload-map (make-hash-table) "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) +(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. @@ -337,82 +205,69 @@ 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 + ;; We used to store the list of superclasses in the `parent' slot (as a list + ;; of class names). But now this slot holds a list of class objects, and + ;; those parents may not exist yet, so the corresponding class objects may + ;; simply not exist yet. So instead we just don't store the list of parents + ;; here in eieio-defclass-autoload at all, since it seems that they're just + ;; not needed before the class is actually loaded. + (let* ((oldc (cl--find-class cname)) + (newc (eieio--class-make cname))) + (if (eieio--class-p 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) - - )))) + ;; turn this into a usable self-pointing symbol + (when eieio-backward-compatibility + (set cname cname) + (make-obsolete-variable cname (format "use \\='%s instead" cname) + "25.1")) + + ;; 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. + (setf (cl--find-class cname) newc) + + ;; Create an autoload on top of our constructor function. + (autoload cname filename doc nil nil) + (autoload (intern (format "%s-p" cname)) filename "" nil nil) + (when eieio-backward-compatibility + (autoload (intern (format "%s-child-p" cname)) filename "" nil nil) + (autoload (intern (format "%s-list-p" cname)) 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. + (autoload-do-load (symbol-function cname))) ; cname + +(cl-deftype list-of (elem-type) + `(and list + (satisfies (lambda (list) + (cl-every (lambda (elem) (cl-typep elem ',elem-type)) + list))))) + + +(defun eieio-make-class-predicate (class) + (lambda (obj) + (:documentation + (format "Return non-nil if OBJ is an object of type `%S'.\n\n(fn OBJ)" + class)) + (and (eieio-object-p obj) + (same-class-p obj class)))) + +(defun eieio-make-child-predicate (class) + (lambda (obj) + (:documentation + (format "Return non-nil if OBJ is an object of type `%S' or a subclass. +\n(fn OBJ)" class)) + (and (eieio-object-p obj) + (object-of-class-p obj class)))) + +(defvar eieio--known-slot-names nil) + +(defun eieio-defclass-internal (cname superclasses slots options) "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. +SLOTS are the slots residing in that class definition, and OPTIONS +holds the class options. 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 @@ -420,385 +275,214 @@ See `defclass' for more information." (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))) + (let* ((oldc (let ((c (cl--find-class cname))) (if (eieio--class-p c) c))) + (newc (or oldc + ;; Reuse `oldc' instead of creating a new one, so that + ;; existing references stay valid. E.g. when + ;; reloading the file that does the `defclass', we don't + ;; want to create a new class object. + (eieio--class-make 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 + (cl-assert (eq newc oldc)) + ;; Reset the fields. + (setf (eieio--class-parents newc) nil) + (setf (eieio--class-slots newc) nil) + (setf (eieio--class-initarg-tuples newc) nil) + (setf (eieio--class-class-slots newc) nil)) + ;; 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 ((children (gethash cname eieio-defclass-autoload-map))) + (when children + (setf (eieio--class-children newc) children) + (remhash cname eieio-defclass-autoload-map)))) + + (if superclasses (progn - (while pname - (if (and (car pname) (symbolp (car pname))) - (if (not (class-p (car pname))) + (dolist (p superclasses) + (if (not (and p (symbolp p))) + (error "Invalid parent class %S" p) + (let ((c (cl--find-class p))) + (if (not (eieio--class-p c)) ;; bad class - (error "Given parent class %s is not a class" (car pname)) + (error "Given parent class %S is not a class" p) ;; 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)))))) + (cl-pushnew cname (eieio--class-children c)) ;; 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))) + (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) + (eieio--class-option c :custom-groups)) + ;; Save parent in child. + (push c (eieio--class-parents newc)))))) ;; 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))) ) + (cl-callf nreverse (eieio--class-parents 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) - )) + ;; save new child in parent + (cl-pushnew cname (eieio--class-children eieio-default-superclass)) + ;; save parent in child + (setf (eieio--class-parents newc) (list eieio-default-superclass)))) - ;; 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)))) + ;; turn this into a usable self-pointing symbol; FIXME: Why? + (when eieio-backward-compatibility + (set cname cname) + (make-obsolete-variable cname (format "use \\='%s instead" cname) + "25.1")) ;; 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))))) + (when eieio-backward-compatibility + (let ((csym (intern (concat (symbol-name cname) "-list-p")))) + (defalias 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)))) + (make-obsolete csym (format + "use (cl-typep ... \\='(list-of %s)) instead" + cname) + "25.1"))) ;; Before adding new slots, let's add all the methods and classes ;; in from the parent class. - (eieio-copy-parents-into-subclass newc superclasses) + (eieio-copy-parents-into-subclass newc) ;; 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) + (setf (cl--find-class cname) 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 + (pcase-dolist (`(,name . ,slot) slots) + (let* ((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)) + (initarg (plist-get slot :initarg)) + (docstr (plist-get slot :documentation)) + (prot (plist-get slot :protection)) + (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 (eieio--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))) + (setq prot + (pcase prot + ((or 'nil 'public ':public) nil) + ((or 'protected ':protected) 'protected) + ((or 'private ':private) 'private) + (_ (signal 'invalid-slot-type (list :protection prot))))) ;; 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) + (if eieio-backward-compatibility + (and initarg (not (keywordp initarg)) + (progn + (set initarg initarg) + (make-obsolete-variable + initarg (format "use \\='%s instead" initarg) "25.1")))) + + ;; The customgroup should be a list of symbols. + (cond ((and (null customg) custom) (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) + ;; The customgroup better be a list of symbols. + (dolist (cg customg) + (unless (symbolp cg) + (signal 'invalid-slot-type (list :group cg)))) ;; 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) + (eieio--add-new-slot + newc (cl--make-slot-descriptor + name init type + `(,@(if docstr `((:documentation . ,docstr))) + ,@(if custom `((:custom . ,custom))) + ,@(if label `((:label . ,label))) + ,@(if customg `((:group . ,customg))) + ,@(if printer `((:printer . ,printer))) + ,@(if prot `((:protection . ,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))) + (dolist (cg customg) + (cl-pushnew cg groups :test #'equal)) + )) ;; 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))) + ;; Fix that up now and then them into vectors. + (cl-callf (lambda (slots) (apply #'vector (nreverse slots))) + (eieio--class-slots newc)) + (cl-callf 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))) - ) + (cl-callf (lambda (slots) (apply #'vector slots)) + (eieio--class-class-slots newc)) + + ;; Also, setup the class allocated values. + (let* ((slots (eieio--class-class-slots newc)) + (n (length slots)) + (v (make-vector n nil))) + (dotimes (i n) + (setf (aref v i) (eieio-default-eval-maybe + (cl--slot-descriptor-initform (aref slots i))))) + (setf (eieio--class-class-allocation-values newc) v)) + + ;; Attach slot symbols into a hashtable, and store the index of + ;; this slot as the value this table. + (let* ((slots (eieio--class-slots newc)) + ;; (cslots (eieio--class-class-slots newc)) + (oa (make-hash-table :test #'eq))) + ;; (dotimes (cnt (length cslots)) + ;; (setf (gethash (cl--slot-descriptor-name (aref cslots cnt)) oa) (- -1 cnt))) + (dotimes (cnt (length slots)) + (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) cnt)) + (setf (eieio--class-index-table newc) oa)) ;; 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)) + (let ((docstring (eieio--class-option-assoc options :documentation))) + (setf (eieio--class-docstring newc) docstring) + (when eieio-backward-compatibility + (put cname 'variable-documentation docstring))) ;; 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))) + (add-to-list 'current-load-list `(define-type . ,cname)) ;; 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) + (let ((g (eieio--class-option-assoc options :custom-groups))) + (mapc (lambda (cg) (cl-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))))) @@ -808,14 +492,21 @@ See `defclass' for more information." ;; 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)) + (if clearparent (setf (eieio--class-parents 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 ((cache (make-vector (+ (length (eieio--class-slots newc)) + (eval-when-compile eieio--object-num-slots)) + nil)) + ;; We don't strictly speaking need to use a symbol, but the old + ;; code used the class's name rather than the class's object, so + ;; we follow this preference for using a symbol, which is probably + ;; convenient to keep the printed representation of such Elisp + ;; objects readable. + (tag (intern (format "eieio-class-tag--%s" cname)))) + (set tag newc) + (fset tag :quick-object-witness-check) + (setf (eieio--object-class-tag cache) tag) (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.. @@ -831,523 +522,172 @@ See `defclass' for more information." "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 +(defun eieio--perform-slot-validation-for-default (slot skipnil) + "For SLOT, signal if its type does not match its default value. +If SKIPNIL is non-nil, then if default value is nil return t instead." + (let ((value (cl--slot-descriptor-initform slot)) + (spec (cl--slot-descriptor-type slot))) + (if (not (or (eieio-eval-default-p value) ;FIXME: Why? + eieio-skip-typecheck + (and skipnil (null value)) + (eieio--perform-slot-validation spec value))) + (signal 'invalid-slot-type (list (cl--slot-descriptor-name slot) spec value))))) + +(defun eieio--slot-override (old new skipnil) + (cl-assert (eq (cl--slot-descriptor-name old) (cl--slot-descriptor-name new))) + ;; There is a match, and we must override the old value. + (let* ((a (cl--slot-descriptor-name old)) + (tp (cl--slot-descriptor-type old)) + (d (cl--slot-descriptor-initform new)) + (type (cl--slot-descriptor-type new)) + (oprops (cl--slot-descriptor-props old)) + (nprops (cl--slot-descriptor-props new)) + (custg (alist-get :group nprops))) + ;; 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)) + (setf (cl--slot-descriptor-type new) tp)) + ;; If we have a repeat, only update the initarg... + (unless (eq d eieio-unbound) + (eieio--perform-slot-validation-for-default new skipnil) + (setf (cl--slot-descriptor-initform old) d)) + + ;; 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 (alist-get :protection oprops)) + (prot (alist-get :protection nprops))) + (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* ((list1 (alist-get :group oprops))) + (dolist (elt custg) + (unless (memq elt list1) + (push elt list1))) + (setf (alist-get :group (cl--slot-descriptor-props old)) list1))) + ;; End PLN + + ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is + ;; set, simply replaces the old one. + (dolist (prop '(:custom :label :documentation :printer)) + (when (alist-get prop (cl--slot-descriptor-props new)) + (setf (alist-get prop (cl--slot-descriptor-props old)) + (alist-get prop (cl--slot-descriptor-props new)))) + + ) )) + +(defun eieio--add-new-slot (newc slot 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. + "Add into NEWC attribute SLOT. +If a slot of that name already exists in NEWC, then do nothing. If it doesn't exist, +INIT is the initarg, if any. 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) + (let* ((a (cl--slot-descriptor-name slot)) + (d (cl--slot-descriptor-initform slot)) + (old (car (cl-member a (eieio--class-slots newc) + :key #'cl--slot-descriptor-name))) + (cold (car (cl-member a (eieio--class-class-slots newc) + :key #'cl--slot-descriptor-name)))) + (cl-pushnew a eieio--known-slot-names) + (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 cold (setq alloc :class)) + + (if (memq alloc '(nil :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 old) + (progn + (eieio--perform-slot-validation-for-default slot skipnil) + (push slot (eieio--class-slots 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 + (eieio--slot-override old slot skipnil))) + (when init + (cl-pushnew (cons init a) (eieio--class-initarg-tuples newc) + :test #'equal))) + + ;; CLASS ALLOCATED SLOTS + (if (not cold) + (progn + (eieio--perform-slot-validation-for-default slot skipnil) + ;; Here we have found a :class version of a slot. This + ;; requires a very different approach. + (push slot (eieio--class-class-slots newc))) + (when defaultoverride + ;; There is a match, and we must override the old value. + (eieio--slot-override cold slot skipnil)))))) + +(defun eieio-copy-parents-into-subclass (newc) "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 + (let ((sn (eieio--class-option-assoc (eieio--class-options newc) + :allow-nil-initform))) + (dolist (pcv (eieio--class-parents newc)) ;; 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))) - )) + (let ((pslots (eieio--class-slots pcv)) + (pinit (eieio--class-initarg-tuples pcv))) + (dotimes (i (length pslots)) + (let* ((sd (cl--copy-slot-descriptor (aref pslots i))) + (init (car (rassq (cl--slot-descriptor-name sd) pinit)))) + (eieio--add-new-slot newc sd init nil nil sn)) + )) ;; while/let + ;; Now duplicate all the class alloc slots. + (let ((pcslots (eieio--class-class-slots pcv))) + (dotimes (i (length pcslots)) + (eieio--add-new-slot newc (cl--copy-slot-descriptor + (aref pcslots i)) + nil :class sn) + ))))) -;;; 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) + +(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))) + (cl-typep value spec))) -(defun eieio-validate-slot-value (class slot-idx value slot) +(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 @@ -1355,22 +695,25 @@ 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) + (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) + (let ((st (cl--slot-descriptor-type (aref (eieio--class-slots class) + slot-idx)))) + (if (not (eieio--perform-slot-validation st value)) + (signal 'invalid-slot-type + (list (eieio--class-name 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)))))) + (let ((st (cl--slot-descriptor-type (aref (eieio--class-class-slots class) + slot-idx)))) + (if (not (eieio--perform-slot-validation st value)) + (signal 'invalid-slot-type + (list (eieio--class-name 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. @@ -1383,55 +726,74 @@ Argument FN is the function calling this verifier." ;;; 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))) + (declare (compiler-macro + (lambda (exp) + (ignore obj) + (pcase slot + ((and (or `',name (and name (pred keywordp))) + (guard (not (memq name eieio--known-slot-names)))) + (macroexp--warn-and-return + (format-message "Unknown slot `%S'" name) exp 'compile-only)) + (_ exp))))) + (cl-check-type slot symbol) + (cl-check-type obj (or eieio-object class)) + (let* ((class (cond ((symbolp obj) + (error "eieio-oref called on a class: %s" obj) + (let ((c (cl--find-class obj))) + (if (eieio--class-p c) (eieio-class-un-autoload obj)) + c)) + (t (eieio--object-class obj)))) + (c (eieio--slot-name-index class 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)) + (if (setq c (eieio--class-slot-name-index class slot)) ;; Oref that slot. - (aref (eieio--class-class-allocation-values (class-v class)) c) + (aref (eieio--class-class-allocation-values 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) + (cl-check-type obj eieio-object) (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))) + (cl-check-type obj (or eieio-object class)) + (cl-check-type slot symbol) + (let* ((cl (cond ((symbolp obj) (cl--find-class obj)) + ((eieio-object-p obj) (eieio--object-class obj)) + (t obj))) + (c (eieio--slot-name-index cl 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)) + (eieio--class-slot-name-index cl slot)) ;; Oref that slot. - (aref (eieio--class-class-allocation-values (class-v cl)) + (aref (eieio--class-class-allocation-values 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))))) + (let ((val (cl--slot-descriptor-initform + (aref (eieio--class-slots cl) + (- c (eval-when-compile eieio--object-num-slots)))))) (eieio-default-eval-maybe val)) - obj cl 'oref-default)))) + obj (eieio--class-name cl) 'oref-default)))) (defun eieio-default-eval-maybe (val) "Check VAL, and return what `oref-default' would provide." + ;; FIXME: What the hell is this supposed to do? Shouldn't it evaluate + ;; variables as well? Why not just always call `eval'? (cond ;; Is it a function call? If so, evaluate it. ((eieio-eval-default-p val) @@ -1445,115 +807,100 @@ Fills in OBJ's SLOT with its default 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))) + (cl-check-type obj eieio-object) + (cl-check-type slot symbol) + (let* ((class (eieio--object-class obj)) + (c (eieio--slot-name-index class 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)) + (eieio--class-slot-name-index class 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))) + (eieio--validate-class-slot-value class c value slot) + (aset (eieio--class-class-allocation-values class) 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) + (eieio--validate-slot-value class 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) - )))) + (setq class (eieio--class-object class)) + (cl-check-type class eieio--class) + (cl-check-type slot symbol) + (let* ((c (eieio--slot-name-index class 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) c + value)) + (signal 'invalid-slot-name (list (eieio--class-name class) slot))) + ;; `oset-default' on an instance-allocated slot is allowed by EIEIO but + ;; not by CLOS and is mildly inconsistent with the :initform thingy, so + ;; it'd be nice to get of it. This said, it is/was used at one place by + ;; gnus/registry.el, so it might be used elsewhere as well, so let's + ;; keep it for now. + ;; FIXME: Generate a compile-time warning for it! + ;; (error "Can't `oset-default' an instance-allocated slot: %S of %S" + ;; slot class) + (eieio--validate-slot-value class c value slot) + ;; Set this into the storage for defaults. + (if (eieio-eval-default-p value) + (error "Can't set default to a sexp that gets evaluated again")) + (setf (cl--slot-descriptor-initform + ;; FIXME: Apparently we set it both in `slots' and in + ;; `object-cache', which seems redundant. + (aref (eieio--class-slots class) + (- c (eval-when-compile eieio--object-num-slots)))) + value) + ;; Take the value, and put it into our cache object. + (eieio-oset (eieio--class-default-object-cache 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. +(defun eieio--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." ;; 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))) + (let* ((fsi (gethash slot (eieio--class-index-table class)))) (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) + (+ (eval-when-compile eieio--object-num-slots) fsi) + (let ((fn (eieio--initarg-to-attribute class slot))) + (if fn + ;; Accessing a slot via its :initarg is accepted by EIEIO + ;; (but not CLOS) but is a bad idea (for one: it's slower). + ;; FIXME: We should emit a compile-time warning when this happens! + (eieio--slot-name-index class 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)))) + (let ((index nil) + (slots (eieio--class-class-slots class))) + (dotimes (i (length slots)) + (if (eq slot (cl--slot-descriptor-name (aref slots i))) + (setq index i))) + index)) ;;; ;; Way to assign slots based on a list. Used for constructors, or @@ -1564,36 +911,26 @@ reverse-lookup that name, and recurse with the associated slot value." 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) + (let ((slots (eieio--class-slots (eieio--object-class obj)))) + (dotimes (i (length slots)) + (let* ((name (cl--slot-descriptor-name (aref slots i))) + (df (eieio-oref-default obj name))) + (if (or df set-all) + (eieio-oset obj name df)))))) + +(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))))) + (let ((tuple (assoc initarg (eieio--class-initarg-tuples 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" +(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)) @@ -1603,14 +940,11 @@ This is usually a symbol that starts with `:'." found)) class)) -(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) +(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)) + (setq remaining-inputs (delq nil remaining-inputs)) + (if (null remaining-inputs) ;; 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 @@ -1621,42 +955,42 @@ If a consistent order does not exist, signal an error." (tail remaining-inputs) (next (progn (while (and tail (not found)) - (setq found (and (car tail) - (eieio-c3-candidate (caar tail) - remaining-inputs)) + (setq found (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 + (eieio--c3-merge-lists (cons next reversed-partial-result) - (mapcar (lambda (l) (if (eq (first l) next) (rest l) l)) + (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l)) remaining-inputs)) ;; The graph is inconsistent, give up (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) -(defun eieio-class-precedence-c3 (class) +(defsubst eieio--class/struct-parents (class) + (or (eieio--class-parents class) + `(,eieio-default-superclass))) + +(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 + (let ((parents (eieio--class-parents (cl--find-class class)))) + (eieio--c3-merge-lists (list class) (append (or - (mapcar - (lambda (x) - (eieio-class-precedence-c3 x)) - parents) - '((eieio-default-superclass))) + (mapcar #'eieio--class-precedence-c3 parents) + `((,eieio-default-superclass))) (list parents)))) ) ;;; ;; Method Invocation Order: Depth First -(defun eieio-class-precedence-dfs (class) +(defun eieio--class-precedence-dfs (class) "Return all parents of CLASS in depth-first order." - (let* ((parents (eieio-class-parents-fast class)) + (let* ((parents (eieio--class-parents class)) (classes (copy-sequence (apply #'append (list class) @@ -1664,9 +998,9 @@ If a consistent order does not exist, signal an error." (mapcar (lambda (parent) (cons parent - (eieio-class-precedence-dfs parent))) + (eieio--class-precedence-dfs parent))) parents) - '((eieio-default-superclass)))))) + `((,eieio-default-superclass)))))) (tail classes)) ;; Remove duplicates. (while tail @@ -1676,588 +1010,187 @@ If a consistent order does not exist, signal an error." ;;; ;; Method Invocation Order: Breadth First -(defun eieio-class-precedence-bfs (class) +(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)))) + (let* ((result) + (queue (eieio--class/struct-parents class))) (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)))))))) + (unless (eq head eieio-default-superclass) + (setq queue (append queue (eieio--class/struct-parents head))))))) (cons class (nreverse result))) ) ;;; ;; Method Invocation Order -(defun eieio-class-precedence-list (class) +(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)) + (if (or (null class) (eq class eieio-default-superclass)) nil - (case (class-method-invocation-order class) + (unless (eieio--class-default-object-cache class) + (eieio-class-un-autoload (eieio--class-name class))) + (cl-case (eieio--class-method-invocation-order class) (:depth-first - (eieio-class-precedence-dfs class)) + (eieio--class-precedence-dfs class)) (:breadth-first - (eieio-class-precedence-bfs class)) + (eieio--class-precedence-bfs class)) (:c3 - (eieio-class-precedence-c3 class)))) + (eieio--class-precedence-c3 class)))) ) (define-obsolete-function-alias - 'class-precedence-list 'eieio-class-precedence-list "24.4") + 'class-precedence-list 'eieio--class-precedence-list "24.4") -;;; CLOS generics internal function handling +;;; Here are some special types of errors ;; -(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)) - ) +(define-error 'invalid-slot-name "Invalid slot name") +(define-error 'invalid-slot-type "Invalid slot type") +(define-error 'unbound-slot "Unbound slot") +(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy") + +;;; Hooking into cl-generic. + +(require 'cl-generic) + +;;;; General support to dispatch based on the type of the argument. + +(cl-generic-define-generalizer eieio--generic-generalizer + ;; Use the exact same tagcode as for cl-struct, so that methods + ;; that dispatch on both kinds of objects get to share this + ;; part of the dispatch code. + 50 #'cl--generic-struct-tag + (lambda (tag &rest _) + (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) + (mapcar #'eieio--class-name + (eieio--class-precedence-list (symbol-value tag)))))) + +(cl-defmethod cl-generic-generalizers :extra "class" (specializer) + ;; CLHS says: + ;; A class must be defined before it can be used as a parameter + ;; specializer in a defmethod form. + ;; So we can ignore types that are not known to denote classes. + (or + (and (eieio--class-p (eieio--class-object specializer)) + (list eieio--generic-generalizer)) + (cl-call-next-method))) + +;;;; Dispatch for arguments which are classes. + +;; Since EIEIO does not support metaclasses, users can't easily use the +;; "dispatch on argument type" for class arguments. That's why EIEIO's +;; `defmethod' added the :static qualifier. For cl-generic, such a qualifier +;; would not make much sense (e.g. to which argument should it apply?). +;; Instead, we add a new "subclass" specializer. + +(defun eieio--generic-subclass-specializers (tag &rest _) + (when (eieio--class-p tag) + (mapcar (lambda (class) + `(subclass ,(eieio--class-name class))) + (eieio--class-precedence-list tag)))) + +(cl-generic-define-generalizer eieio--generic-subclass-generalizer + 60 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name))) + #'eieio--generic-subclass-specializers) + +(cl-defmethod cl-generic-generalizers ((_specializer (head subclass))) + (list eieio--generic-subclass-generalizer)) - (if (or (not lambdas) (not (car lambdas))) + +;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "bd51800d7de6429a2c9a6a600ba2dc52") +;;; Generated autoloads from eieio-compat.el - ;; 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))) +(autoload 'eieio--defalias "eieio-compat" "\ +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. - ;; Do the regular implementation here. +\(fn NAME BODY)" nil nil) - (run-hook-with-args 'eieio-pre-method-execution-functions - lambdas) +(autoload 'defgeneric "eieio-compat" "\ +Create a generic function METHOD. +DOC-STRING is the base documentation for this class. A generic +function has no body, as its purpose is to decide which method body +is appropriate to use. Uses `defmethod' to create methods, and calls +`defgeneric' for you. With this implementation the ARGS are +currently ignored. You can use `defgeneric' to apply specialized +top level documentation to a method. - (setq lastval (apply (car lambdas) newargs)) - (setq rval lastval - rvalever t) - ) +\(fn METHOD ARGS &optional DOC-STRING)" nil 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)))) +(function-put 'defgeneric 'doc-string-elt '3) + +(make-obsolete 'defgeneric 'cl-defgeneric '"25.1") + +(autoload 'defmethod "eieio-compat" "\ +Create a new METHOD through `defgeneric' with ARGS. + +The optional second argument KEY is a specifier that +modifies how the method is called, including: + :before - Method will be called before the :primary + :primary - The default if not specified + :after - Method will be called after the :primary + :static - First arg could be an object or class +The next argument is the ARGLIST. The ARGLIST specifies the arguments +to the method as with `defun'. The first argument can have a type +specifier, such as: + ((VARNAME CLASS) ARG2 ...) +where VARNAME is the name of the local variable for the method being +created. The CLASS is a class symbol for a class made with `defclass'. +A DOCSTRING comes after the ARGLIST, and is optional. +All the rest of the args are the BODY of the method. A method will +return the value of the last form in the BODY. + +Summary: + + (defmethod mymethod [:before | :primary | :after | :static] + ((typearg class-name) arg2 &optional opt &rest rest) + \"doc-string\" + body) + +\(fn METHOD &rest ARGS)" nil t) + +(function-put 'defmethod 'doc-string-elt '3) + +(make-obsolete 'defmethod 'cl-defmethod '"25.1") + +(autoload 'eieio--defgeneric-init-form "eieio-compat" "\ + + +\(fn METHOD DOC-STRING)" nil nil) + +(autoload 'eieio--defmethod "eieio-compat" "\ - -;;; -;; 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))))) +\(fn METHOD KIND ARGCLASS CODE)" nil nil) +(autoload 'eieio-defmethod "eieio-compat" "\ +Obsolete work part of an old version of the `defmethod' macro. + +\(fn METHOD ARGS)" nil nil) + +(make-obsolete 'eieio-defmethod 'cl-defmethod '"24.1") + +(autoload 'eieio-defgeneric "eieio-compat" "\ +Obsolete work part of an old version of the `defgeneric' macro. + +\(fn METHOD DOC-STRING)" nil nil) + +(make-obsolete 'eieio-defgeneric 'cl-defgeneric '"24.1") + +(autoload 'eieio-defclass "eieio-compat" "\ + + +\(fn CNAME SUPERCLASSES SLOTS OPTIONS)" nil nil) + +(make-obsolete 'eieio-defclass 'eieio-defclass-internal '"25.1") + +;;;*** -;;; 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) diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index aff07b29edf..31d0b85c55a 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -1,6 +1,6 @@ -;;; eieio-custom.el -- eieio object customization +;;; eieio-custom.el -- eieio object customization -*- lexical-binding:t -*- -;; Copyright (C) 1999-2001, 2005, 2007-2013 Free Software Foundation, +;; Copyright (C) 1999-2001, 2005, 2007-2015 Free Software Foundation, ;; Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -70,7 +70,7 @@ of these.") :documentation "A number of thingies.")) "A class for testing the widget on.") -(defcustom eieio-widget-test (eieio-widget-test-class "Foo") +(defcustom eieio-widget-test (eieio-widget-test-class) "Test variable for editing an object." :type 'object :group 'eieio) @@ -136,7 +136,7 @@ Updates occur regardless of the current customization group.") )) (widget-value-set vc (widget-value vc)))) -(defun eieio-custom-toggle-parent (widget &rest ignore) +(defun eieio-custom-toggle-parent (widget &rest _) "Toggle visibility of parent of WIDGET. Optional argument IGNORE is an extraneous parameter." (eieio-custom-toggle-hide (widget-get widget :parent))) @@ -154,7 +154,7 @@ Optional argument IGNORE is an extraneous parameter." :clone-object-children nil ) -(defun eieio-object-match (widget value) +(defun eieio-object-match (_widget _value) "Match info for WIDGET against VALUE." ;; Write me t) @@ -184,7 +184,7 @@ Optional argument IGNORE is an extraneous parameter." (if (not (widget-get widget :value)) (widget-put widget :value (cond ((widget-get widget :objecttype) - (funcall (class-constructor + (funcall (eieio--class-constructor (widget-get widget :objecttype)) "Custom-new")) ((widget-get widget :objectcreatefcn) @@ -193,12 +193,8 @@ Optional argument IGNORE is an extraneous parameter." (let* ((chil nil) (obj (widget-get widget :value)) (master-group (widget-get widget :eieio-group)) - (cv (class-v (eieio--object-class obj))) - (slots (eieio--class-public-a cv)) - (flabel (eieio--class-public-custom-label cv)) - (fgroup (eieio--class-public-custom-group cv)) - (fdoc (eieio--class-public-doc cv)) - (fcust (eieio--class-public-custom cv))) + (cv (eieio--object-class obj)) + (slots (eieio--class-slots cv))) ;; First line describes the object, but may not editable. (if (widget-get widget :eieio-show-name) (setq chil (cons (widget-create-child-and-convert @@ -208,7 +204,8 @@ Optional argument IGNORE is an extraneous parameter." chil))) ;; Display information about the group being shown (when master-group - (let ((groups (class-option (eieio--object-class obj) :custom-groups))) + (let ((groups (eieio--class-option (eieio--object-class obj) + :custom-groups))) (widget-insert "Groups:") (while groups (widget-insert " ") @@ -216,7 +213,7 @@ Optional argument IGNORE is an extraneous parameter." (widget-insert "*" (capitalize (symbol-name master-group)) "*") (widget-create 'push-button :thing (cons obj (car groups)) - :notify (lambda (widget &rest stuff) + :notify (lambda (widget &rest _) (eieio-customize-object (car (widget-get widget :thing)) (cdr (widget-get widget :thing)))) @@ -224,63 +221,60 @@ Optional argument IGNORE is an extraneous parameter." (setq groups (cdr groups))) (widget-insert "\n\n"))) ;; Loop over all the slots, creating child widgets. - (while slots - ;; Output this slot if it has a customize flag associated with it. - (when (and (car fcust) - (or (not master-group) (member master-group (car fgroup))) - (slot-boundp obj (car slots))) - ;; In this case, this slot has a custom type. Create its - ;; children widgets. - (let ((type (eieio-filter-slot-type widget (car fcust))) - (stuff nil)) - ;; This next bit is an evil hack to get some EDE functions - ;; working the way I like. - (if (and (listp type) - (setq stuff (member :slotofchoices type))) - (let ((choices (eieio-oref obj (car (cdr stuff)))) - (newtype nil)) - (while (not (eq (car type) :slotofchoices)) - (setq newtype (cons (car type) newtype) - type (cdr type))) - (while choices - (setq newtype (cons (list 'const (car choices)) - newtype) - choices (cdr choices))) - (setq type (nreverse newtype)))) - (setq chil (cons (widget-create-child-and-convert - widget 'object-slot - :childtype type - :sample-face 'eieio-custom-slot-tag-face - :tag - (concat - (make-string - (or (widget-get widget :indent) 0) - ? ) - (if (car flabel) - (car flabel) - (let ((s (symbol-name - (or - (class-slot-initarg - (eieio--object-class obj) - (car slots)) - (car slots))))) - (capitalize - (if (string-match "^:" s) - (substring s (match-end 0)) - s))))) - :value (slot-value obj (car slots)) - :doc (if (car fdoc) (car fdoc) - "Slot not Documented.") - :eieio-custom-visibility 'visible - ) - chil)) - ) - ) - (setq slots (cdr slots) - fdoc (cdr fdoc) - fcust (cdr fcust) - flabel (cdr flabel) - fgroup (cdr fgroup))) + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (sname (eieio-slot-descriptor-name slot)) + (props (cl--slot-descriptor-props slot))) + ;; Output this slot if it has a customize flag associated with it. + (when (and (alist-get :custom props) + (or (not master-group) + (member master-group (alist-get :group props))) + (slot-boundp obj (cl--slot-descriptor-name slot))) + ;; In this case, this slot has a custom type. Create its + ;; children widgets. + (let ((type (eieio-filter-slot-type widget (alist-get :custom props))) + (stuff nil)) + ;; This next bit is an evil hack to get some EDE functions + ;; working the way I like. + (if (and (listp type) + (setq stuff (member :slotofchoices type))) + (let ((choices (eieio-oref obj (car (cdr stuff)))) + (newtype nil)) + (while (not (eq (car type) :slotofchoices)) + (setq newtype (cons (car type) newtype) + type (cdr type))) + (while choices + (setq newtype (cons (list 'const (car choices)) + newtype) + choices (cdr choices))) + (setq type (nreverse newtype)))) + (setq chil (cons (widget-create-child-and-convert + widget 'object-slot + :childtype type + :sample-face 'eieio-custom-slot-tag-face + :tag + (concat + (make-string + (or (widget-get widget :indent) 0) + ?\s) + (or (alist-get :label props) + (let ((s (symbol-name + (or + (eieio--class-slot-initarg + (eieio--object-class obj) + sname) + sname)))) + (capitalize + (if (string-match "^:" s) + (substring s (match-end 0)) + s))))) + :value (slot-value obj sname) + :doc (or (alist-get :documentation props) + "Slot not Documented.") + :eieio-custom-visibility 'visible + ) + chil)) + )))) (widget-put widget :children (nreverse chil)) )) @@ -288,40 +282,46 @@ Optional argument IGNORE is an extraneous parameter." "Get the value of WIDGET." (let* ((obj (widget-get widget :value)) (master-group eieio-cog) - (cv (class-v (eieio--object-class obj))) - (fgroup (eieio--class-public-custom-group cv)) (wids (widget-get widget :children)) (name (if (widget-get widget :eieio-show-name) (car (widget-apply (car wids) :value-inline)) nil)) (chil (if (widget-get widget :eieio-show-name) (nthcdr 1 wids) wids)) - (cv (class-v (eieio--object-class obj))) - (slots (eieio--class-public-a cv)) - (fcust (eieio--class-public-custom cv))) + (cv (eieio--object-class obj)) + (i 0) + (slots (eieio--class-slots cv))) ;; If there are any prefix widgets, clear them. ;; -- None yet ;; Create a batch of initargs for each slot. - (while (and slots chil) - (if (and (car fcust) - (or eieio-custom-ignore-eieio-co - (not master-group) (member master-group (car fgroup))) - (slot-boundp obj (car slots))) - (progn - ;; Only customized slots have widgets - (let ((eieio-custom-ignore-eieio-co t)) - (eieio-oset obj (car slots) - (car (widget-apply (car chil) :value-inline)))) - (setq chil (cdr chil)))) - (setq slots (cdr slots) - fgroup (cdr fgroup) - fcust (cdr fcust))) + (while (and (< i (length slots)) chil) + (let* ((slot (aref slots i)) + (props (cl--slot-descriptor-props slot)) + (cust (alist-get :custom props))) + ;; + ;; Shouldn't I be incremented unconditionally? Or + ;; better shouldn't we simply mapc on the slots vector + ;; avoiding use of this integer variable? PLN Sat May + ;; 2 07:35:45 2015 + ;; + (setq i (+ i 1)) + (if (and cust + (or eieio-custom-ignore-eieio-co + (not master-group) + (member master-group (alist-get :group props))) + (slot-boundp obj (cl--slot-descriptor-name slot))) + (progn + ;; Only customized slots have widgets + (let ((eieio-custom-ignore-eieio-co t)) + (eieio-oset obj (cl--slot-descriptor-name slot) + (car (widget-apply (car chil) :value-inline)))) + (setq chil (cdr chil)))))) ;; Set any name updates on it. - (if name (setf (eieio--object-name obj) name)) + (if name (eieio-object-set-name-string obj name)) ;; This is the same object we had before. obj)) -(defmethod eieio-done-customizing ((obj eieio-default-superclass)) +(cl-defmethod eieio-done-customizing ((_obj eieio-default-superclass)) "When applying change to a widget, call this method. This method is called by the default widget-edit commands. User made commands should also call this method when applying changes. @@ -344,7 +344,7 @@ Optional argument GROUP is the sub-group of slots to display." "Major mode for customizing EIEIO objects. \\{eieio-custom-mode-map}") -(defmethod eieio-customize-object ((obj eieio-default-superclass) +(cl-defmethod eieio-customize-object ((obj eieio-default-superclass) &optional group) "Customize OBJ in a specialized custom buffer. To override call the `eieio-custom-widget-insert' to just insert the @@ -383,20 +383,20 @@ These groups are specified with the `:group' slot flag." (make-local-variable 'eieio-co) (setq eieio-co obj) (make-local-variable 'eieio-cog) - (setq eieio-cog group))) + (setq eieio-cog g))) -(defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass)) +(cl-defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass)) "Insert an Apply and Reset button into the object editor. Argument OBJ is the object being customized." (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _) (widget-apply eieio-wo :value-get) (eieio-done-customizing eieio-co) (bury-buffer)) "Accept") (widget-insert " ") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _) ;; I think the act of getting it sets ;; its value through the get function. (message "Applying Changes...") @@ -406,17 +406,17 @@ Argument OBJ is the object being customized." "Apply") (widget-insert " ") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _) (message "Resetting") (eieio-customize-object eieio-co eieio-cog)) "Reset") (widget-insert " ") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _) (bury-buffer)) "Cancel")) -(defmethod eieio-custom-widget-insert ((obj eieio-default-superclass) +(cl-defmethod eieio-custom-widget-insert ((obj eieio-default-superclass) &rest flags) "Insert the widget used for editing object OBJ in the current buffer. Arguments FLAGS are widget compatible flags. @@ -431,13 +431,11 @@ Must return the created widget." :clone-object-children t ) -(defun eieio-object-value-to-abstract (widget value) +(defun eieio-object-value-to-abstract (_widget value) "For WIDGET, convert VALUE to an abstract /safe/ representation." - (if (eieio-object-p value) value - (if (null value) value - nil))) + (if (eieio-object-p value) value)) -(defun eieio-object-abstract-to-value (widget value) +(defun eieio-object-abstract-to-value (_widget value) "For WIDGET, convert VALUE from an abstract /safe/ representation." value) @@ -447,21 +445,22 @@ Must return the created widget." ;; These functions provide the ability to create dynamic menus to ;; customize specific sections of an object. They do not hook directly ;; into a filter, but can be used to create easymenu vectors. -(defmethod eieio-customize-object-group ((obj eieio-default-superclass)) +(cl-defmethod eieio-customize-object-group ((obj eieio-default-superclass)) "Create a list of vectors for customizing sections of OBJ." (mapcar (lambda (group) (vector (concat "Group " (symbol-name group)) (list 'customize-object obj (list 'quote group)) t)) - (class-option (eieio--object-class obj) :custom-groups))) + (eieio--class-option (eieio--object-class obj) :custom-groups))) (defvar eieio-read-custom-group-history nil "History for the custom group reader.") -(defmethod eieio-read-customization-group ((obj eieio-default-superclass)) +(cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass)) "Do a completing read on the name of a customization group in OBJ. Return the symbol for the group, or nil" - (let ((g (class-option (eieio--object-class obj) :custom-groups))) + (let ((g (eieio--class-option (eieio--object-class obj) + :custom-groups))) (if (= (length g) 1) (car g) ;; Make the association list @@ -473,4 +472,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 d3ae8b191e1..c820180359b 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. +;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -*- lexical-binding:t -*- -;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2015 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp @@ -31,6 +31,9 @@ ;;; Code: +(declare-function data-debug/eieio-insert-slots "eieio-datadebug" + (obj eieio-default-superclass)) + (defun data-debug-insert-object-slots (object prefix) "Insert all the slots of OBJECT. PREFIX specifies what to insert at the start of each line." @@ -54,16 +57,17 @@ PREFIX specifies what to insert at the start of each line." "Insert a button representing OBJECT. PREFIX is the text that precedes the button. PREBUTTONTEXT is some text between PREFIX and the object button." - (let ((start (point)) - (end nil) - (str (object-print object)) - (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" - (eieio-object-name-string object) - (eieio-object-class object) - (eieio-class-parents (eieio-object-class object)) - (length (object-slots object)) - )) - ) + (let* ((start (point)) + (end nil) + (str (object-print object)) + (class (eieio-object-class object)) + (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" + (eieio-object-name-string object) + class + (eieio-class-parents class) + (length (eieio-class-slots class)) + )) + ) (insert prefix prebuttontext str) (setq end (point)) (put-text-property (- end (length str)) end 'face 'font-lock-keyword-face) @@ -79,70 +83,46 @@ 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) +(cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) + prefix) "Insert the slots of OBJ into the current DDEBUG buffer." (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) + (let* ((cv (eieio--object-class obj))) + (data-debug-insert-thing (eieio--class-name cv) 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 ((slots (eieio--class-slots cv))) + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (sname (cl--slot-descriptor-name slot)) + (i (eieio--class-slot-initarg cv sname)) + (sstr (concat (symbol-name (or i sname)) " "))) + (if (slot-boundp obj sname) + (let* ((v (eieio-oref obj sname))) + (data-debug-insert-thing v prefix sstr)) + ;; Unbound case + (data-debug-insert-custom + "#unbound" prefix sstr + 'font-lock-keyword-face) + ))))))) ;;; Augment the Data debug thing display list. -(data-debug-add-specialized-thing (lambda (thing) (object-p thing)) +(data-debug-add-specialized-thing (lambda (thing) (eieio-object-p thing)) #'data-debug-insert-object-button) ;;; DEBUG METHODS ;; ;; A generic function to run DDEBUG on an object and popup a new buffer. ;; -(defmethod data-debug-show ((obj eieio-default-superclass)) +(cl-defmethod data-debug-show ((obj eieio-default-superclass)) "Run ddebug against any EIEIO object OBJ." (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj))) (data-debug-insert-object-slots obj "]")) -;;; DEBUG FUNCTIONS -;; -(defun eieio-debug-methodinvoke (method class) - "Show the method invocation order for METHOD with CLASS object." - (interactive "aMethod: \nXClass Expression: ") - (let* ((eieio-pre-method-execution-functions - (lambda (l) (throw 'moose l) )) - (data - (catch 'moose (eieio-generic-call - method (list class)))) - (buf (data-debug-new-buffer "*Method Invocation*")) - (data2 (mapcar (lambda (sym) - (symbol-function (car sym))) - data))) - (data-debug-insert-thing data2 ">" ""))) - (provide 'eieio-datadebug) ;;; eieio-datadebug.el ends here diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 27f97b31ebe..a5d8b6fcf89 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-2015 Free Software ;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -31,7 +31,6 @@ (require 'eieio) (require 'find-func) (require 'speedbar) -(require 'help-mode) ;;; Code: ;;;###autoload @@ -45,7 +44,7 @@ variable `eieio-default-superclass'." nil t))) nil)) (if (not root-class) (setq root-class 'eieio-default-superclass)) - (eieio--check-type class-p root-class) + (cl-check-type root-class class) (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t) (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*") (erase-buffer) @@ -58,9 +57,9 @@ variable `eieio-default-superclass'." Argument THIS-ROOT is the local root of the tree. Argument PREFIX is the character prefix to use. Argument CH-PREFIX is another character prefix to display." - (eieio--check-type class-p this-root) + (cl-check-type this-root class) (let ((myname (symbol-name this-root)) - (chl (eieio--class-children (class-v this-root))) + (chl (eieio--class-children (cl--find-class this-root))) (fprefix (concat ch-prefix " +--")) (mprefix (concat ch-prefix " | ")) (lprefix (concat ch-prefix " "))) @@ -74,215 +73,11 @@ Argument CH-PREFIX is another character prefix to display." ;;; CLASS COMPLETION / DOCUMENTATION -;;;###autoload(defalias 'describe-class 'eieio-describe-class) +;; Called via help-fns-describe-function-functions. +(declare-function help-fns-short-filename "help-fns" (filename)) ;;;###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." - (let* ((cv (class-v class)) - (docs (eieio--class-public-doc cv)) - (names (eieio--class-public-a cv)) - (deflt (eieio--class-public-d cv)) - (types (eieio--class-public-type cv)) - (publp (eieio--class-public-printer cv)) - (i 0) - (prot (eieio--class-protection cv)) - ) - (princ "Instance Allocated Slots:") - (terpri) - (terpri) - (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) - (setq names (cdr names) - docs (cdr docs) - deflt (cdr deflt) - publp (cdr publp) - prot (cdr prot) - i (1+ i))) - (setq docs (eieio--class-class-allocation-doc cv) - names (eieio--class-class-allocation-a cv) - types (eieio--class-class-allocation-type cv) - i 0 - prot (eieio--class-class-allocation-protection cv)) - (when names - (terpri) - (princ "Class Allocated Slots:")) - (terpri) - (terpri) - (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)) - (error nil)) - (when (car docs) - (terpri) - (princ " ") - (princ (car docs)) - (terpri)) - (terpri) - (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) - (apply #'append - (mapcar - (lambda (c) - (append (list c) (eieio-build-class-list c))) - (eieio-class-children-fast class))) - (list class))) +(define-obsolete-function-alias 'eieio-help-class 'cl--describe-class "25.1") (defun eieio-build-class-alist (&optional class instantiable-only buildlist) "Return an alist of all currently active classes for completion purposes. @@ -290,15 +85,16 @@ Optional argument CLASS is the class to start with. If INSTANTIABLE-ONLY is non nil, only allow names of classes which are not abstract, otherwise allow all classes. Optional argument BUILDLIST is more list to attach and is used internally." - (let* ((cc (or class eieio-default-superclass)) - (sublst (eieio--class-children (class-v cc)))) + (let* ((cc (or class 'eieio-default-superclass)) + (sublst (eieio--class-children (cl--find-class cc)))) (unless (assoc (symbol-name cc) buildlist) (when (or (not instantiable-only) (not (class-abstract-p cc))) + ;; FIXME: Completion tables don't need alists, and ede/generic.el needs + ;; the symbols rather than their names. (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) - (while sublst + (dolist (elem sublst) (setq buildlist (eieio-build-class-alist - (car sublst) instantiable-only buildlist)) - (setq sublst (cdr sublst))) + elem instantiable-only buildlist))) buildlist)) (defvar eieio-read-class nil @@ -326,163 +122,39 @@ 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) ;;;###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-lambda-arglist (func) - "Return the argument list of FUNC, a function body." - (if (symbolp func) (setq func (symbol-function func))) - (if (byte-code-function-p func) - (eieio-compiled-function-arglist func) - (car (cdr func)))) - -(defun eieio-all-generic-functions (&optional class) - "Return a list of all generic functions. -Optional CLASS argument returns only those functions that contain -methods for CLASS." - (let ((l nil) tree (cn (if class (symbol-name class) nil))) - (mapatoms - (lambda (symbol) - (setq tree (get symbol 'eieio-method-obarray)) - (if tree - (progn - ;; A symbol might be interned for that class in one of - ;; these three slots in the method-obarray. - (if (or (not class) - (fboundp (intern-soft cn (aref tree 0))) - (fboundp (intern-soft cn (aref tree 1))) - (fboundp (intern-soft cn (aref tree 2)))) - (setq l (cons symbol l))))))) - l)) - -(defun eieio-method-documentation (generic class) - "Return a list of the specific documentation of GENERIC for CLASS. -If there is not an explicit method for CLASS in GENERIC, or if that -function has no documentation, then return nil." - (let ((tree (get generic 'eieio-method-obarray)) - (cn (symbol-name class)) - before primary after) - (if (not tree) - nil - ;; A symbol might be interned for that class in one of - ;; these three slots in the method-obarray. - (setq before (intern-soft cn (aref tree 0)) - primary (intern-soft cn (aref tree 1)) - after (intern-soft cn (aref tree 2))) - (if (not (or (fboundp before) - (fboundp primary) - (fboundp after))) - nil - (list (if (fboundp before) - (cons (eieio-lambda-arglist before) - (documentation before)) - nil) - (if (fboundp primary) - (cons (eieio-lambda-arglist primary) - (documentation primary)) - nil) - (if (fboundp after) - (cons (eieio-lambda-arglist after) - (documentation after)) - nil)))))) - -(defvar eieio-read-generic nil - "History of the `eieio-read-generic' prompt.") - -(defun eieio-read-generic-p (fn) - "Function used in function `eieio-read-generic'. -This is because `generic-p' is a macro. -Argument FN is the function to test." - (generic-p fn)) - -(defun eieio-read-generic (prompt &optional historyvar) - "Read a generic function from the minibuffer with PROMPT. -Optional argument HISTORYVAR is the variable to use as history." - (intern (completing-read prompt obarray 'eieio-read-generic-p - t nil (or historyvar 'eieio-read-generic)))) +(defun eieio-help-constructor (ctr) + "Describe CTR if it is a class constructor." + (when (class-p ctr) + (erase-buffer) + (let ((location (find-lisp-object-file-name ctr 'define-type)) + (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 (substitute-command-keys " in `")) + (help-insert-xref-button + (help-fns-short-filename location) + 'cl-type-definition ctr location 'define-type) + (insert (substitute-command-keys "'"))) + (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)) + )))) + ;;; METHOD STATS ;; @@ -490,7 +162,7 @@ Optional argument HISTORYVAR is the variable to use as history." (defun eieio-display-method-list () "Display a list of all the methods and what features are used." (interactive) - (let* ((meth1 (eieio-all-generic-functions)) + (let* ((meth1 (cl--generic-all-functions)) (meth (sort meth1 (lambda (a b) (string< (symbol-name a) (symbol-name b))))) @@ -571,142 +243,17 @@ Optional argument HISTORYVAR is the variable to use as history." (princ "Methods Primary Only: ") (prin1 primaryonly) (princ "\t") - (princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100))) + (princ (format "%d" (floor (* 100.0 primaryonly) methidx))) (princ "% of total methods") (terpri) (princ "Only One Primary Impl: ") (prin1 oneprimary) (princ "\t") - (princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100))) + (princ (format "%d" (floor (* 100.0 oneprimary) primaryonly))) (princ "% of total primary methods") (terpri) )) -;;; HELP AUGMENTATION -;; -(define-button-type 'eieio-method-def - :supertype 'help-xref - 'help-function (lambda (class method file) - (eieio-help-find-method-definition class method file)) - 'help-echo (purecopy "mouse-2, RET: find method's definition")) - -(define-button-type 'eieio-class-def - :supertype 'help-xref - 'help-function (lambda (class file) - (eieio-help-find-class-definition class file)) - 'help-echo (purecopy "mouse-2, RET: find class definition")) - -(defun eieio-help-find-method-definition (class method file) - (let ((filename (find-library-name file)) - location buf) - (when (null filename) - (error "Cannot find library %s" file)) - (setq buf (find-file-noselect filename)) - (with-current-buffer buf - (goto-char (point-min)) - (when - (re-search-forward - ;; Regexp for searching methods. - (concat "(defmethod[ \t\r\n]+" method - "\\([ \t\r\n]+:[a-zA-Z]+\\)?" - "[ \t\r\n]+(\\s-*(\\(\\sw\\|\\s_\\)+\\s-+" - class - "\\s-*)") - nil t) - (setq location (match-beginning 0)))) - (if (null location) - (message "Unable to find location in file") - (pop-to-buffer buf) - (goto-char location) - (recenter) - (beginning-of-line)))) - -(defun eieio-help-find-class-definition (class file) - (let ((filename (find-library-name file)) - location buf) - (when (null filename) - (error "Cannot find library %s" file)) - (setq buf (find-file-noselect filename)) - (with-current-buffer buf - (goto-char (point-min)) - (when - (re-search-forward - ;; Regexp for searching a class. - (concat "(defclass[ \t\r\n]+" class "[ \t\r\n]+") - nil t) - (setq location (match-beginning 0)))) - (if (null location) - (message "Unable to find location in file") - (pop-to-buffer buf) - (goto-char location) - (recenter) - (beginning-of-line)))) - - -(defun eieio-help-mode-augmentation-maybee (&rest unused) - "For buffers thrown into help mode, augment for EIEIO. -Arguments UNUSED are not used." - ;; 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 ;; @@ -743,21 +290,21 @@ Arguments UNUSED are not used." () "Menu part in easymenu format used in speedbar while in `eieio' mode.") -(defun eieio-class-speedbar (dir-or-object depth) +(defun eieio-class-speedbar (_dir-or-object _depth) "Create buttons in speedbar that represents the current project. 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. - (eieio-class-button eieio-default-superclass 0) + ;; Create and expand the default object. + (eieio-class-button 'eieio-default-superclass 0) (forward-line -1) (speedbar-expand-line))) (defun eieio-class-button (class depth) "Draw a speedbar button at the current point for CLASS at DEPTH." - (eieio--check-type class-p class) - (let ((subclasses (eieio--class-children (class-v class)))) + (cl-check-type class class) + (let ((subclasses (eieio--class-children (cl--find-class class)))) (if subclasses (speedbar-make-tag-line 'angle ?+ 'eieio-sb-expand @@ -782,7 +329,7 @@ Argument INDENT is the depth of indentation." (speedbar-with-writable (save-excursion (end-of-line) (forward-char 1) - (let ((subclasses (eieio--class-children (class-v class)))) + (let ((subclasses (eieio--class-children (cl--find-class class)))) (while subclasses (eieio-class-button (car subclasses) (1+ indent)) (setq subclasses (cdr subclasses))))))) @@ -792,13 +339,17 @@ Argument INDENT is the depth of indentation." (t (error "Ooops... not sure what to do"))) (speedbar-center-buffer-smartly)) -(defun eieio-describe-class-sb (text token indent) +(defun eieio-describe-class-sb (_text token _indent) "Describe the class TEXT in TOKEN. INDENT is the current indentation level." (dframe-with-attached-buffer - (eieio-describe-class token)) + (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 e964263754f..a1eabcf9700 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. +;;; eieio-speedbar.el -- Classes for managing speedbar displays. -*- lexical-binding:t -*- -;; Copyright (C) 1999-2002, 2005, 2007-2013 Free Software Foundation, +;; Copyright (C) 1999-2002, 2005, 2007-2015 Free Software Foundation, ;; Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -196,19 +196,19 @@ that path." ;; when no other methods are found, allowing multiple inheritance to work ;; reliably with eieio-speedbar. -(defmethod eieio-speedbar-description (object) +(cl-defmethod eieio-speedbar-description (object) "Return a string describing OBJECT." (eieio-object-name-string object)) -(defmethod eieio-speedbar-derive-line-path (object) +(cl-defmethod eieio-speedbar-derive-line-path (_object) "Return the path which OBJECT has something to do with." nil) -(defmethod eieio-speedbar-object-buttonname (object) +(cl-defmethod eieio-speedbar-object-buttonname (object) "Return a string to use as a speedbar button for OBJECT." (eieio-object-name-string object)) -(defmethod eieio-speedbar-make-tag-line (object depth) +(cl-defmethod eieio-speedbar-make-tag-line (object depth) "Insert a tag line into speedbar at point for OBJECT. By default, all objects appear as simple TAGS with no need to inherit from the special `eieio-speedbar' classes. Child classes should redefine this @@ -221,7 +221,7 @@ Argument DEPTH is the depth at which the tag line is inserted." 'speedbar-tag-face depth)) -(defmethod eieio-speedbar-handle-click (object) +(cl-defmethod eieio-speedbar-handle-click (object) "Handle a click action on OBJECT in speedbar. Any object can be represented as a tag in SPEEDBAR without special attributes. These default objects will be pulled up in a custom @@ -285,7 +285,7 @@ Add one of the child classes to this class to the parent list of a class." ;;; Methods to eieio-speedbar-* which do not need to be overridden ;; -(defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) +(cl-defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) depth) "Insert a tag line into speedbar at point for OBJECT. All objects a child of symbol `eieio-speedbar' can be created from @@ -321,12 +321,12 @@ Argument DEPTH is the depth at which the tag line is inserted." (if exp (eieio-speedbar-expand object (1+ depth)))))) -(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth) +(cl-defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) _depth) "Base method for creating tag lines for non-object children." (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s" (eieio-object-name object))) -(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) +(cl-defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) "Expand OBJECT at indentation DEPTH. Inserts a list of new tag lines representing expanded elements within OBJECT." @@ -340,7 +340,7 @@ OBJECT." ;;; Speedbar specific function callbacks. ;; -(defun eieio-speedbar-object-click (text token indent) +(defun eieio-speedbar-object-click (_text token _indent) "Handle a user click on TEXT representing object TOKEN. The object is at indentation level INDENT." (eieio-speedbar-handle-click token)) @@ -362,7 +362,7 @@ TOKEN is the object. INDENT is the current indentation level." (t (error "Ooops... not sure what to do"))) (speedbar-center-buffer-smartly)) -(defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) +(cl-defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) "Return a description for a child of OBJ which is not an object." (error "You must implement `eieio-speedbar-child-description' for %s" (eieio-object-name obj))) @@ -412,7 +412,7 @@ Optional DEPTH is the depth we start at." ;;; Methods to the eieio-speedbar-* classes which need to be overridden. ;; -(defmethod eieio-speedbar-object-children ((object eieio-speedbar)) +(cl-defmethod eieio-speedbar-object-children ((_object eieio-speedbar)) "Return a list of children to be displayed in speedbar. If the return value is a list of OBJECTs, then those objects are queried for details. If the return list is made of strings, diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index fc5da3198f9..790e8bc9e0e 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 +;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*- ;;; or maybe Eric's Implementation of Emacs Interpreted Objects -;; Copyright (C) 1995-1996, 1998-2013 Free Software Foundation, Inc. +;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 1.4 @@ -36,15 +36,13 @@ ;; Retrieved from: ;; http://192.220.96.201/dylan/linearization-oopsla96.html -;; There is funny stuff going on with typep and deftype. This -;; is the only way I seem to be able to make this stuff load properly. - ;; @TODO - fix :initform to be a form, not a quoted value ;; @TODO - Prefix non-clos functions with `eieio-'. -;;; Code: +;; TODO: better integrate CL's defstructs and classes. E.g. make it possible +;; to create a new class that inherits from a struct. -(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! +;;; Code: (defvar eieio-version "1.4" "Current version of EIEIO.") @@ -59,13 +57,11 @@ ;;; Defining a new class ;; -(defmacro defclass (name superclass slots &rest options-and-doc) +(defmacro defclass (name superclasses slots &rest options-and-doc) "Define NAME as a new class derived from SUPERCLASS with SLOTS. OPTIONS-AND-DOC is used as the class' options and base documentation. -SUPERCLASS is a list of superclasses to inherit from, with SLOTS -being the slots residing in that class definition. NOTE: Currently -only one slot may exist in SUPERCLASS as multiple inheritance is not -yet supported. Supported tags are: +SUPERCLASSES is a list of superclasses to inherit from, with SLOTS +being the slots residing in that class definition. Supported tags are: :initform - Initializing form. :initarg - Tag used during initialization. @@ -79,8 +75,6 @@ yet supported. Supported tags are: - A string documenting use of this slot. The following are extensions on CLOS: - :protection - Specify protection for this slot. - Defaults to `:public'. Also use `:protected', or `:private'. :custom - When customizing an object, the custom :type. Public only. :label - A text string label used for a slot when customizing. :group - Name of a customization group this slot belongs in. @@ -115,96 +109,175 @@ 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'." - ;; 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))) - - -;;; CLOS style implementation of object creators. -;; -(defun make-instance (class &rest initargs) - "Make a new instance of CLASS based on INITARGS. -CLASS is a class symbol. For example: - - (make-instance 'foo) - - INITARGS is a property list with keywords based on the :initarg -for each slot. For example: - - (make-instance 'foo :slot1 value1 :slotN valueN) - -Compatibility note: + (declare (doc-string 4)) + (cl-check-type superclasses list) + + (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'"))) + + (if (stringp (car options-and-doc)) + (setq options-and-doc + (cons :documentation options-and-doc))) + + ;; Make sure the method invocation order is a valid value. + (let ((io (eieio--class-option-assoc options-and-doc + :method-invocation-order))) + (when (and io (not (member io '(:depth-first :breadth-first :c3)))) + (error "Method invocation order %s is not allowed" io))) + + (let ((testsym1 (intern (concat (symbol-name name) "-p"))) + (testsym2 (intern (format "%s--eieio-childp" name))) + (accessors ())) + + ;; Collect the accessors we need to define. + (pcase-dolist (`(,sname . ,soptions) slots) + (let* ((acces (plist-get soptions :accessor)) + (initarg (plist-get soptions :initarg)) + (reader (plist-get soptions :reader)) + (writer (plist-get soptions :writer)) + (alloc (plist-get soptions :allocation)) + (label (plist-get soptions :label))) + + ;; Update eieio--known-slot-names already in case we compile code which + ;; uses this before the class is loaded. + (cl-pushnew sname eieio--known-slot-names) + + (if eieio-error-unsupported-class-tags + (let ((tmp soptions)) + (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)))))) + + ;; Make sure the :allocation parameter has a valid value. + (if (not (memq alloc '(nil :class :instance))) + (signal 'invalid-slot-type (list :allocation alloc))) + + ;; 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")) + + ;; 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. + (when acces + (push `(cl-defmethod (setf ,acces) (value (this ,name)) + (eieio-oset this ',sname value)) + accessors) + (push `(cl-defmethod ,acces ((this ,name)) + ,(format + "Retrieve the slot `%S' from an object of class `%S'." + sname name) + ;; FIXME: Why is this different from the :reader case? + (if (slot-boundp this ',sname) (eieio-oref this ',sname))) + accessors) + (when (and eieio-backward-compatibility (eq alloc :class)) + ;; FIXME: How could I declare this *method* as obsolete. + (push `(cl-defmethod ,acces ((this (subclass ,name))) + ,(format + "Retrieve the class slot `%S' from a class `%S'. +This method is obsolete." + sname name) + (if (slot-boundp this ',sname) + (eieio-oref-default this ',sname))) + accessors))) + + ;; 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 + (push `(cl-defmethod ,writer ((this ,name) value) + ,(format "Set the slot `%S' of an object of class `%S'." + sname name) + (setf (slot-value this ',sname) value)) + accessors)) + ;; If a reader is defined, then create a generic method + ;; of that name whose purpose is to access this slot value. + (if reader + (push `(cl-defmethod ,reader ((this ,name)) + ,(format "Access the slot `%S' from object of class `%S'." + sname name) + (slot-value this ',sname)) + accessors)) + )) -If the first element of INITARGS is a string, it is used as the -name of the class. - -In EIEIO, the class' constructor requires a name for use when printing. -`make-instance' in CLOS doesn't use names the way Emacs does, so the -class is used as the name slot instead when INITARGS doesn't start with -a string." - (if (and (car initargs) (stringp (car initargs))) - (apply (class-constructor class) initargs) - (apply (class-constructor class) - (cond ((symbolp class) (symbol-name class)) - (t (format "%S" class))) - initargs))) - - -;;; CLOS methods and generics -;; -(defmacro defgeneric (method args &optional doc-string) - "Create a generic function METHOD. -DOC-STRING is the base documentation for this class. A generic -function has no body, as its purpose is to decide which method body -is appropriate to use. Uses `defmethod' to create methods, and calls -`defgeneric' for you. With this implementation the ARGS are -currently ignored. You can use `defgeneric' to apply specialized -top level documentation to a method." - `(eieio--defalias ',method - (eieio--defgeneric-init-form ',method ,doc-string))) - -(defmacro defmethod (method &rest args) - "Create a new METHOD through `defgeneric' with ARGS. - -The optional second argument KEY is a specifier that -modifies how the method is called, including: - :before - Method will be called before the :primary - :primary - The default if not specified - :after - Method will be called after the :primary - :static - First arg could be an object or class -The next argument is the ARGLIST. The ARGLIST specifies the arguments -to the method as with `defun'. The first argument can have a type -specifier, such as: - ((VARNAME CLASS) ARG2 ...) -where VARNAME is the name of the local variable for the method being -created. The CLASS is a class symbol for a class made with `defclass'. -A DOCSTRING comes after the ARGLIST, and is optional. -All the rest of the args are the BODY of the method. A method will -return the value of the last form in the BODY. - -Summary: - - (defmethod mymethod [:before | :primary | :after | :static] - ((typearg class-name) arg2 &optional opt &rest rest) - \"doc-string\" - body)" - (let* ((key (if (keywordp (car args)) (pop args))) - (params (car args)) - (arg1 (car params)) - (fargs (if (consp arg1) - (cons (car arg1) (cdr params)) - params)) - (class (if (consp arg1) (nth 1 arg1))) - (code `(lambda ,fargs ,@(cdr args)))) `(progn - ;; Make sure there is a generic and the byte-compiler sees it. - (defgeneric ,method ,args - ,(or (documentation code) - (format "Generically created method `%s'." method))) - (eieio--defmethod ',method ',key ',class #',code)))) + ;; This test 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 functions. + (defalias ',testsym1 (eieio-make-class-predicate ',name)) + (defalias ',testsym2 (eieio-make-child-predicate ',name)) + + ,@(when eieio-backward-compatibility + (let ((f (intern (format "%s-child-p" name)))) + `((defalias ',f ',testsym2) + (make-obsolete + ',f ,(format "use (cl-typep ... \\='%s) instead" name) + "25.1")))) + + ;; 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. + + (put ',name 'cl-deftype-satisfies #',testsym2) + + (eieio-defclass-internal ',name ',superclasses ',slots ',options-and-doc) + + ,@accessors + + ;; Create the constructor function + ,(if (eieio--class-option-assoc options-and-doc :abstract) + ;; Abstract classes cannot be instantiated. Say so. + (let ((abs (eieio--class-option-assoc options-and-doc :abstract))) + (if (not (stringp abs)) + (setq abs (format "Class %s is abstract" name))) + `(defun ,name (&rest _) + ,(format "You cannot create a new object of type `%S'." name) + (error ,abs))) + + ;; Non-abstract classes need a constructor. + `(defun ,name (&rest slots) + ,(format "Create a new object of class type `%S'." name) + (declare (compiler-macro + (lambda (whole) + (if (not (stringp (car slots))) + whole + (macroexp--warn-and-return + (format "Obsolete name arg %S to constructor %S" + (car slots) (car whole)) + ;; Keep the name arg, for backward compatibility, + ;; but hide it so we don't trigger indefinitely. + `(,(car whole) (identity ,(car slots)) + ,@(cdr slots))))))) + (apply #'make-instance ',name slots)))))) + ;;; Get/Set slots in an object. ;; @@ -212,16 +285,19 @@ Summary: "Retrieve the value stored in OBJ in the slot named by SLOT. Slot is the name of the slot when created by `defclass' or the label created by the :initarg tag." + (declare (debug (form symbolp))) `(eieio-oref ,obj (quote ,slot))) (defalias 'slot-value 'eieio-oref) (defalias 'set-slot-value 'eieio-oset) +(make-obsolete 'set-slot-value "use (setf (slot-value ..) ..) instead" "25.1") (defmacro oref-default (obj slot) "Get the default value of OBJ (maybe a class) for SLOT. The default value is the value installed in a class with the :initform tag. SLOT can be the slot name, or the tag specified by the :initarg tag in the `defclass' call." + (declare (debug (form symbolp))) `(eieio-oref-default ,obj (quote ,slot))) ;;; Handy CLOS macros @@ -245,54 +321,108 @@ SPEC-LIST is of a form similar to `let'. For example: Where each VAR is the local variable given to the associated SLOT. A slot specified without a variable name is given a variable name of the same name as the slot." - (declare (indent 2)) - ;; Transform the spec-list into a symbol-macrolet spec-list. - (let ((mappings (mapcar (lambda (entry) - (let ((var (if (listp entry) (car entry) entry)) - (slot (if (listp entry) (cadr entry) entry))) - (list var `(slot-value ,object ',slot)))) - spec-list))) - (append (list 'symbol-macrolet mappings) - body))) + (declare (indent 2) (debug (sexp sexp def-body))) + (require 'cl-lib) + ;; Transform the spec-list into a cl-symbol-macrolet spec-list. + (macroexp-let2 nil object object + `(cl-symbol-macrolet + ,(mapcar (lambda (entry) + (let ((var (if (listp entry) (car entry) entry)) + (slot (if (listp entry) (cadr entry) entry))) + (list var `(slot-value ,object ',slot)))) + spec-list) + ,@body))) + +;; Keep it as a non-inlined function, so the internals of object don't get +;; hard-coded in random .elc files. +(defun eieio-pcase-slot-index-table (obj) + "Return some data structure from which can be extracted the slot offset." + (eieio--class-index-table + (symbol-value (eieio--object-class-tag obj)))) + +(defun eieio-pcase-slot-index-from-index-table (index-table slot) + "Find the index to pass to `aref' to access SLOT." + (let ((index (gethash slot index-table))) + (if index (+ (eval-when-compile + (length (cl-struct-slot-info 'eieio--object))) + index)))) + +(pcase-defmacro eieio (&rest fields) + "Pcase patterns to match EIEIO objects. +Elements of FIELDS can be of the form (NAME PAT) in which case the contents of +field NAME is matched against PAT, or they can be of the form NAME which +is a shorthand for (NAME NAME)." + (declare (debug (&rest [&or (sexp pcase-PAT) sexp]))) + (let ((is (make-symbol "table"))) + ;; FIXME: This generates a horrendous mess of redundant let bindings. + ;; `pcase' needs to be improved somehow to introduce let-bindings more + ;; sparingly, or the byte-compiler needs to be taught to optimize + ;; them away. + ;; FIXME: `pcase' does not do a good job here of sharing tests&code among + ;; various branches. + `(and (pred eieio-object-p) + (app eieio-pcase-slot-index-table ,is) + ,@(mapcar (lambda (field) + (let* ((name (if (consp field) (car field) field)) + (pat (if (consp field) (cadr field) field)) + (i (make-symbol "index"))) + `(and (let (and ,i (pred natnump)) + (eieio-pcase-slot-index-from-index-table + ,is ',name)) + (app (pcase--flip aref ,i) ,pat)))) + fields)))) ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. ;; + (define-obsolete-function-alias - 'object-class-fast #'eieio--object-class "24.4") + 'object-class-fast #'eieio-object-class "24.4") + +(cl-defgeneric eieio-object-name-string (obj) + "Return a string which is OBJ's name." + (declare (obsolete eieio-named "25.1"))) (defun eieio-object-name (obj &optional extra) - "Return a Lisp like symbol string for object OBJ. + "Return a printed representation for object OBJ. If EXTRA, include that in the string returned to represent the symbol." - (eieio--check-type eieio-object-p obj) - (format "#<%s %s%s>" (symbol-name (eieio--object-class obj)) - (eieio--object-name obj) (or extra ""))) + (cl-check-type obj eieio-object) + (format "#<%s %s%s>" (eieio-object-class obj) + (eieio-object-name-string obj) (or extra ""))) (define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") -(defun eieio-object-name-string (obj) "Return a string which is OBJ's name." - (eieio--check-type eieio-object-p obj) - (eieio--object-name obj)) +(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key)) + +;; In the past, every EIEIO object had a `name' field, so we had the two method +;; below "for free". Since this field is very rarely used, we got rid of it +;; and instead we keep it in a weak hash-tables, for those very rare objects +;; that use it. +(cl-defmethod eieio-object-name-string (obj) + (or (gethash obj eieio--object-names) + (symbol-name (eieio-object-class obj)))) (define-obsolete-function-alias 'object-name-string #'eieio-object-name-string "24.4") -(defun eieio-object-set-name-string (obj name) +(cl-defmethod eieio-object-set-name-string (obj name) "Set the string which is OBJ's NAME." - (eieio--check-type eieio-object-p obj) - (eieio--check-type stringp name) - (setf (eieio--object-name obj) name)) + (declare (obsolete eieio-named "25.1")) + (cl-check-type name string) + (setf (gethash obj eieio--object-names) name)) (define-obsolete-function-alias 'object-set-name-string 'eieio-object-set-name-string "24.4") -(defun eieio-object-class (obj) "Return the class struct defining OBJ." - (eieio--check-type eieio-object-p obj) - (eieio--object-class obj)) +(defun eieio-object-class (obj) + "Return the class struct defining OBJ." + ;; FIXME: We say we return a "struct" but we return a symbol instead! + (cl-check-type obj eieio-object) + (eieio--class-name (eieio--object-class obj))) (define-obsolete-function-alias 'object-class #'eieio-object-class "24.4") ;; CLOS name, maybe? (define-obsolete-function-alias 'class-of #'eieio-object-class "24.4") (defun eieio-object-class-name (obj) "Return a Lisp like symbol name for OBJ's class." - (eieio--check-type eieio-object-p obj) + (cl-check-type obj eieio-object) (eieio-class-name (eieio--object-class obj))) (define-obsolete-function-alias 'object-class-name 'eieio-object-class-name "24.4") @@ -301,15 +431,15 @@ If EXTRA, include that in the string returned to represent the symbol." "Return parent classes to CLASS. (overload of variable). The CLOS function `class-direct-superclasses' is aliased to this function." - (eieio--check-type class-p class) - (eieio-class-parents-fast class)) + (eieio--class-parents (eieio--class-object class))) + (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") (defun eieio-class-children (class) "Return child classes to CLASS. The CLOS function `class-direct-subclasses' is aliased to this function." - (eieio--check-type class-p class) - (eieio-class-children-fast class)) + (cl-check-type class class) + (eieio--class-children (cl--find-class class))) (define-obsolete-function-alias 'class-children #'eieio-class-children "24.4") @@ -322,16 +452,18 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (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") +(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) - (eieio--check-type eieio-object-p obj) - (same-class-fast-p obj class)) +(defun same-class-p (obj class) + "Return t if OBJ is of class-type CLASS." + (setq class (eieio--class-object class)) + (cl-check-type class eieio--class) + (cl-check-type obj eieio-object) + (eq (eieio--object-class obj) class)) (defun object-of-class-p (obj class) "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." - (eieio--check-type eieio-object-p obj) + (cl-check-type obj eieio-object) ;; class will be checked one layer down (child-of-class-p (eieio--object-class obj) class)) ;; Backwards compatibility @@ -339,23 +471,41 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (defun child-of-class-p (child class) "Return non-nil if CHILD class is a subclass of CLASS." - (eieio--check-type class-p class) - (eieio--check-type class-p child) - (let ((p nil)) - (while (and child (not (eq child class))) - (setq p (append p (eieio--class-parent (class-v child))) - child (car p) - p (cdr p))) - (if child t))) + (setq child (eieio--class-object child)) + (cl-check-type child eieio--class) + ;; `eieio-default-superclass' is never mentioned in eieio--class-parents, + ;; so we have to special case it here. + (or (eq class 'eieio-default-superclass) + (let ((p nil)) + (setq class (eieio--class-object class)) + (cl-check-type class eieio--class) + (while (and child (not (eq child class))) + (setq p (append p (eieio--class-parents child)) + child (pop p))) + (if child t)))) + +(defun eieio-slot-descriptor-name (slot) + (cl--slot-descriptor-name slot)) + +(defun eieio-class-slots (class) + "Return list of slots available in instances of CLASS." + ;; FIXME: This only gives the instance slots and ignores the + ;; class-allocated slots. + (setq class (eieio--class-object class)) + (cl-check-type class eieio--class) + (mapcar #'identity (eieio--class-slots class))) (defun object-slots (obj) - "Return list of slots available in OBJ." - (eieio--check-type eieio-object-p obj) - (eieio--class-public-a (class-v (eieio--object-class obj)))) - -(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." - (eieio--check-type class-p class) - (let ((ia (eieio--class-initarg-tuples (class-v class))) + "Return list of slot names available in OBJ." + (declare (obsolete eieio-class-slots "25.1")) + (cl-check-type obj eieio-object) + (mapcar #'cl--slot-descriptor-name + (eieio-class-slots (eieio--object-class obj)))) + +(defun eieio--class-slot-initarg (class slot) + "Fetch from CLASS, SLOT's :initarg." + (cl-check-type class eieio--class) + (let ((ia (eieio--class-initarg-tuples class)) (f nil)) (while (and ia (not f)) (if (eq (cdr (car ia)) slot) @@ -369,6 +519,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function." "Set the value in OBJ for slot SLOT to VALUE. SLOT is the slot name as specified in `defclass' or the tag created with in the :initarg slot. VALUE can be any Lisp object." + (declare (debug (form symbolp form))) `(eieio-oset ,obj (quote ,slot) ,value)) (defmacro oset-default (class slot value) @@ -376,6 +527,7 @@ with in the :initarg slot. VALUE can be any Lisp object." The default value is usually set with the :initform tag during class creation. This allows users to change the default behavior of classes after they are created." + (declare (debug (form symbolp form))) `(eieio-oset-default ,class (quote ,slot) ,value)) ;;; CLOS queries into classes and slots @@ -390,7 +542,7 @@ OBJECT can be an instance or a class." ;; Return nil if the magic symbol is in there. (not (eq (cond ((eieio-object-p object) (eieio-oref object slot)) - ((class-p object) (eieio-oref-default object slot)) + ((symbolp object) (eieio-oref-default object slot)) (t (signal 'wrong-type-argument (list 'eieio-object-p object)))) eieio-unbound)))) @@ -400,23 +552,28 @@ OBJECT can be an instance or a class." (defun slot-exists-p (object-or-class slot) "Return non-nil if OBJECT-OR-CLASS has SLOT." - (let ((cv (class-v (cond ((eieio-object-p object-or-class) - (eieio-object-class object-or-class)) - ((class-p object-or-class) - object-or-class)) - ))) - (or (memq slot (eieio--class-public-a cv)) - (memq slot (eieio--class-class-allocation-a cv))) - )) + (let ((cv (cond ((eieio-object-p object-or-class) + (eieio--object-class object-or-class)) + ((eieio--class-p object-or-class) object-or-class) + (t (find-class object-or-class 'error))))) + (or (gethash slot (eieio--class-index-table cv)) + ;; FIXME: We could speed this up by adding class slots into the + ;; index-table (e.g. with a negative index?). + (let ((cs (eieio--class-class-slots cv)) + found) + (dotimes (i (length cs)) + (if (eq slot (cl--slot-descriptor-name (aref cs i))) + (setq found t))) + found)))) (defun find-class (symbol &optional errorp) "Return the class that SYMBOL represents. If there is no class, nil is returned if ERRORP is nil. If ERRORP is non-nil, `wrong-argument-type' is signaled." - (if (not (class-p symbol)) - (if errorp (signal 'wrong-type-argument (list 'class-p symbol)) - nil) - (class-v symbol))) + (let ((class (cl--find-class symbol))) + (cond + ((eieio--class-p class) class) + (errorp (signal 'wrong-type-argument (list 'class-p symbol)))))) ;;; Slightly more complex utility functions for objects ;; @@ -426,7 +583,7 @@ LIST is a list of objects whose slots are searched. Objects in LIST do not need to have a slot named SLOT, nor does SLOT need to be bound. If these errors occur, those objects will be ignored." - (eieio--check-type listp list) + (cl-check-type list list) (while (and list (not (condition-case nil ;; This prevents errors for missing slots. (equal key (eieio-oref (car list) slot)) @@ -438,7 +595,7 @@ be ignored." "Return an association list with the contents of SLOT as the key element. LIST must be a list of objects with SLOT in it. This is useful when you need to do completing read on an object group." - (eieio--check-type listp list) + (cl-check-type list list) (let ((assoclist nil)) (while list (setq assoclist (cons (cons (eieio-oref (car list) slot) @@ -452,7 +609,7 @@ This is useful when you need to do completing read on an object group." LIST must be a list of objects, but those objects do not need to have SLOT in it. If it does not, then that element is left out of the association list." - (eieio--check-type listp list) + (cl-check-type list list) (let ((assoclist nil)) (while list (if (slot-exists-p (car list) slot) @@ -494,68 +651,13 @@ If SLOT is unbound, do nothing." nil (eieio-oset object slot (delete item (eieio-oref object slot))))) -;;; -;; Method Calling Functions - -(defun next-method-p () - "Return non-nil if there is a next method. -Returns a list of lambda expressions which is the `next-method' -order." - eieio-generic-call-next-method-list) - -(defun call-next-method (&rest replacement-args) - "Call the superclass method from a subclass method. -The superclass method is specified in the current method list, -and is called the next method. - -If REPLACEMENT-ARGS is non-nil, then use them instead of -`eieio-generic-call-arglst'. The generic arg list are the -arguments passed in at the top level. - -Use `next-method-p' to find out if there is a next method to call." - (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)) - (error "Cannot `call-next-method' except in :primary or :static methods") - ) - (let ((newargs (or replacement-args eieio-generic-call-arglst)) - (next (car eieio-generic-call-next-method-list)) - ) - (if (or (not next) (not (car next))) - (apply 'no-next-method (car newargs) (cdr newargs)) - (let* ((eieio-generic-call-next-method-list - (cdr eieio-generic-call-next-method-list)) - (eieio-generic-call-arglst newargs) - (fcn (car next)) - ) - (eieio--with-scoped-class (cdr next) - (apply fcn newargs)) )))) - ;;; Here are some CLOS items that need the CL package ;; -(defsetf eieio-oref eieio-oset) - -(if (eval-when-compile (fboundp 'gv-define-expander)) - ;; Not needed for Emacs>=24.3 since gv.el's setf expands macros and - ;; follows aliases. - nil -(defsetf slot-value eieio-oset) - -;; The below setf method was written by Arnd Kohrs <kohrs@acm.org> -(define-setf-method oref (obj slot) - (with-no-warnings - (require 'cl) - (let ((obj-temp (gensym)) - (slot-temp (gensym)) - (store-temp (gensym))) - (list (list obj-temp slot-temp) - (list obj `(quote ,slot)) - (list store-temp) - (list 'set-slot-value obj-temp slot-temp - store-temp) - (list 'slot-value obj-temp slot-temp)))))) +;; FIXME: Shouldn't this be a more complex gv-expander which extracts the +;; common code between oref and oset, so as to reduce the redundant work done +;; in (push foo (oref bar baz)), like we do for the `nth' expander? +(gv-define-simple-setter eieio-oref eieio-oset) ;;; @@ -574,48 +676,65 @@ Its slots are automatically adopted by classes with no specified parents. This class is not stored in the `parent' slot of a class vector." :abstract t) +(setq eieio-default-superclass (cl--find-class 'eieio-default-superclass)) + (defalias 'standard-class 'eieio-default-superclass) -(defgeneric constructor (class newname &rest slots) - "Default constructor for CLASS `eieio-default-superclass'.") +(cl-defgeneric make-instance (class &rest initargs) + "Make a new instance of CLASS based on INITARGS. +For example: + + (make-instance \\='foo) + +INITARGS is a property list with keywords based on the `:initarg' +for each slot. For example: + + (make-instance \\='foo :slot1 value1 :slotN valueN)") + +(define-obsolete-function-alias 'constructor #'make-instance "25.1") -(defmethod constructor :static - ((class eieio-default-superclass) newname &rest slots) +(cl-defmethod make-instance + ((class (subclass eieio-default-superclass)) &rest slots) "Default constructor for CLASS `eieio-default-superclass'. -NEWNAME is the name to be given to the constructed object. -SLOTS are the initialization slots used by `shared-initialize'. +SLOTS are the initialization slots used by `initialize-instance'. This static method is called when an object is constructed. It allocates the vector used to represent an EIEIO object, and then -calls `shared-initialize' on that object." - (let* ((new-object (copy-sequence (eieio--class-default-object-cache (class-v class))))) - ;; Update the name for the newly created object. - (setf (eieio--object-name new-object) newname) +calls `initialize-instance' on that object." + (let* ((new-object (copy-sequence (eieio--class-default-object-cache + (eieio--class-object class))))) + (if (and slots + (let ((x (car slots))) + (or (stringp x) (null x)))) + (funcall (if eieio-backward-compatibility #'ignore #'message) + "Obsolete name %S passed to %S constructor" + (pop slots) class)) ;; Call the initialize method on the new object with the slots ;; that were passed down to us. (initialize-instance new-object slots) ;; Return the created object. new-object)) -(defgeneric shared-initialize (obj slots) +;; FIXME: CLOS uses "&rest INITARGS" instead. +(cl-defgeneric shared-initialize (obj slots) "Set slots of OBJ with SLOTS which is a list of name/value pairs. Called from the constructor routine.") -(defmethod shared-initialize ((obj eieio-default-superclass) slots) +(cl-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." - (eieio--with-scoped-class (eieio--object-class obj) - (while slots - (let ((rn (eieio-initarg-to-attribute (eieio--object-class obj) - (car slots)))) - (if (not rn) - (slot-missing obj (car slots) 'oset (car (cdr slots))) - (eieio-oset obj rn (car (cdr slots))))) - (setq slots (cdr (cdr slots)))))) - -(defgeneric initialize-instance (this &optional slots) + (while slots + (let ((rn (eieio--initarg-to-attribute (eieio--object-class obj) + (car slots)))) + (if (not rn) + (slot-missing obj (car slots) 'oset (car (cdr slots))) + (eieio-oset obj rn (car (cdr slots))))) + (setq slots (cdr (cdr slots))))) + +;; FIXME: CLOS uses "&rest INITARGS" instead. +(cl-defgeneric initialize-instance (this &optional slots) "Construct the new object THIS based on SLOTS.") -(defmethod initialize-instance ((this eieio-default-superclass) +(cl-defmethod initialize-instance ((this eieio-default-superclass) &optional slots) "Construct the new object THIS based on SLOTS. SLOTS is a tagged list where odd numbered elements are tags, and @@ -627,10 +746,9 @@ 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* ((this-class (class-v (eieio--object-class this))) - (slot (eieio--class-public-a this-class)) - (defaults (eieio--class-public-d this-class))) - (while slot + (let* ((this-class (eieio--object-class this)) + (slots (eieio--class-slots this-class))) + (dotimes (i (length slots)) ;; For each slot, see if we need to evaluate it. ;; ;; Paul Landes said in an email: @@ -638,20 +756,20 @@ dynamically set from SLOTS." ;; > 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)))) + (let* ((slot (aref slots i)) + (initform (cl--slot-descriptor-initform slot)) + (dflt (eieio-default-eval-maybe initform))) + (when (not (eq dflt initform)) + ;; FIXME: We should be able to just do (aset this (+ i <cst>) dflt)! + (eieio-oset this (cl--slot-descriptor-name slot) dflt))))) ;; Shared initialize will parse our slots for us. (shared-initialize this slots)) -(defgeneric slot-missing (object slot-name operation &optional new-value) +(cl-defgeneric slot-missing (object slot-name operation &optional new-value) "Method invoked when an attempt to access a slot in OBJECT fails.") -(defmethod slot-missing ((object eieio-default-superclass) slot-name - operation &optional new-value) +(cl-defmethod slot-missing ((object eieio-default-superclass) slot-name + _operation &optional _new-value) "Method invoked when an attempt to access a slot in OBJECT fails. SLOT-NAME is the name of the failed slot, OPERATION is the type of access that was requested, and optional NEW-VALUE is the value that was desired @@ -662,10 +780,10 @@ directly reference slots in EIEIO objects." (signal 'invalid-slot-name (list (eieio-object-name object) slot-name))) -(defgeneric slot-unbound (object class slot-name fn) +(cl-defgeneric slot-unbound (object class slot-name fn) "Slot unbound is invoked during an attempt to reference an unbound slot.") -(defmethod slot-unbound ((object eieio-default-superclass) +(cl-defmethod slot-unbound ((object eieio-default-superclass) class slot-name fn) "Slot unbound is invoked during an attempt to reference an unbound slot. OBJECT is the instance of the object being reference. CLASS is the @@ -677,78 +795,44 @@ Use `slot-boundp' to determine if a slot is bound or not. In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but EIEIO can only dispatch on the first argument, so the first two are swapped." - (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) + (signal 'unbound-slot (list (eieio-class-name class) + (eieio-object-name object) slot-name fn))) -(defgeneric no-applicable-method (object method &rest args) - "Called if there are no implementations for OBJECT in METHOD.") - -(defmethod no-applicable-method ((object eieio-default-superclass) - method &rest args) - "Called if there are no implementations for OBJECT in METHOD. -OBJECT is the object which has no method implementation. -ARGS are the arguments that were passed to METHOD. - -Implement this for a class to block this signal. The return -value becomes the return value of the original method call." - (signal 'no-method-definition (list method (eieio-object-name object))) - ) - -(defgeneric no-next-method (object &rest args) -"Called from `call-next-method' when no additional methods are available.") - -(defmethod no-next-method ((object eieio-default-superclass) - &rest args) - "Called from `call-next-method' when no additional methods are available. -OBJECT is othe object being called on `call-next-method'. -ARGS are the arguments it is called by. -This method signals `no-next-method' by default. Override this -method to not throw an error, and its return value becomes the -return value of `call-next-method'." - (signal 'no-next-method (list (eieio-object-name object) args)) - ) - -(defgeneric clone (obj &rest params) +(cl-defgeneric clone (obj &rest params) "Make a copy of OBJ, and then supply PARAMS. PARAMS is a parameter list of the same form used by `initialize-instance'. When overloading `clone', be sure to call `call-next-method' first and modify the returned object.") -(defmethod clone ((obj eieio-default-superclass) &rest params) +(cl-defmethod clone ((obj eieio-default-superclass) &rest params) "Make a copy of OBJ, and then apply PARAMS." - (let ((nobj (copy-sequence obj)) - (nm (eieio--object-name obj)) - (passname (and params (stringp (car params)))) - (num 1)) - (if params (shared-initialize nobj (if passname (cdr params) params))) - (if (not passname) - (save-match-data - (if (string-match "-\\([0-9]+\\)" nm) - (setq num (1+ (string-to-number (match-string 1 nm))) - nm (substring nm 0 (match-beginning 0)))) - (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num)))) - (setf (eieio--object-name nobj) (car params))) + (let ((nobj (copy-sequence obj))) + (if (stringp (car params)) + (funcall (if eieio-backward-compatibility #'ignore #'message) + "Obsolete name %S passed to clone" (pop params))) + (if params (shared-initialize nobj params)) nobj)) -(defgeneric destructor (this &rest params) +(cl-defgeneric destructor (this &rest params) "Destructor for cleaning up any dynamic links to our object.") -(defmethod destructor ((this eieio-default-superclass) &rest params) +(cl-defmethod destructor ((_this eieio-default-superclass) &rest _params) "Destructor for cleaning up any dynamic links to our object. Argument THIS is the object being destroyed. PARAMS are additional ignored parameters." ;; No cleanup... yet. ) -(defgeneric object-print (this &rest strings) +(cl-defgeneric object-print (this &rest strings) "Pretty printer for object THIS. Call function `object-name' with STRINGS. It is sometimes useful to put a summary of the object into the default #<notation> string when using EIEIO browsing tools. Implement this method to customize the summary.") -(defmethod object-print ((this eieio-default-superclass) &rest strings) +(cl-defmethod object-print ((this eieio-default-superclass) &rest strings) "Pretty printer for object THIS. Call function `object-name' with STRINGS. The default method for printing object THIS is to use the function `object-name'. @@ -760,16 +844,16 @@ Implement this function and specify STRINGS in a call to `call-next-method' to provide additional summary information. When passing in extra strings from child classes, always remember to prepend a space." - (eieio-object-name this (apply 'concat strings))) + (eieio-object-name this (apply #'concat strings))) (defvar eieio-print-depth 0 "When printing, keep track of the current indentation depth.") -(defgeneric object-write (this &optional comment) +(cl-defgeneric object-write (this &optional comment) "Write out object THIS to the current stream. Optional COMMENT will add comments to the beginning of the output.") -(defmethod object-write ((this eieio-default-superclass) &optional comment) +(cl-defmethod object-write ((this eieio-default-superclass) &optional comment) "Write object THIS out to the current stream. This writes out the vector version of this object. Complex and recursive object are discouraged from being written. @@ -782,44 +866,43 @@ this object." (princ comment) (princ "\n")) (let* ((cl (eieio-object-class this)) - (cv (class-v cl))) + (cv (cl--find-class cl))) ;; Now output readable lisp to recreate this object ;; It should look like this: ;; (<constructor> <name> <slot> <slot> ... ) ;; Each slot's slot is writen using its :writer. (princ (make-string (* eieio-print-depth 2) ? )) (princ "(") - (princ (symbol-name (class-constructor (eieio-object-class this)))) + (princ (symbol-name (eieio--class-constructor (eieio-object-class this)))) (princ " ") (prin1 (eieio-object-name-string this)) (princ "\n") ;; Loop over all the public slots - (let ((publa (eieio--class-public-a cv)) - (publd (eieio--class-public-d cv)) - (publp (eieio--class-public-printer cv)) + (let ((slots (eieio--class-slots cv)) (eieio-print-depth (1+ eieio-print-depth))) - (while publa - (when (slot-boundp this (car publa)) - (let ((i (class-slot-initarg cl (car publa))) - (v (eieio-oref this (car publa))) - ) - (unless (or (not i) (equal v (car publd))) - (unless (bolp) - (princ "\n")) - (princ (make-string (* eieio-print-depth 2) ? )) - (princ (symbol-name i)) - (if (car publp) - ;; Use our public printer - (progn - (princ " ") - (funcall (car publp) v)) - ;; Use our generic override prin1 function. - (princ (if (or (eieio-object-p v) - (eieio-object-p (car-safe v))) - "\n" " ")) - (eieio-override-prin1 v))))) - (setq publa (cdr publa) publd (cdr publd) - publp (cdr publp)))) + (dotimes (i (length slots)) + (let ((slot (aref slots i))) + (when (slot-boundp this (cl--slot-descriptor-name slot)) + (let ((i (eieio--class-slot-initarg + cv (cl--slot-descriptor-name slot))) + (v (eieio-oref this (cl--slot-descriptor-name slot)))) + (unless (or (not i) (equal v (cl--slot-descriptor-initform slot))) + (unless (bolp) + (princ "\n")) + (princ (make-string (* eieio-print-depth 2) ? )) + (princ (symbol-name i)) + (if (alist-get :printer (cl--slot-descriptor-props slot)) + ;; Use our public printer + (progn + (princ " ") + (funcall (alist-get :printer + (cl--slot-descriptor-props slot)) + v)) + ;; Use our generic override prin1 function. + (princ (if (or (eieio-object-p v) + (eieio-object-p (car-safe v))) + "\n" " ")) + (eieio-override-prin1 v)))))))) (princ ")") (when (= eieio-print-depth 0) (princ "\n")))) @@ -830,12 +913,8 @@ this object." (object-write thing)) ((consp thing) (eieio-list-prin1 thing)) - ((class-p thing) - (princ (eieio-class-name thing))) - ((or (keywordp thing) (booleanp thing)) - (prin1 thing)) - ((symbolp thing) - (princ (concat "'" (symbol-name thing)))) + ((eieio--class-p thing) + (princ (eieio--class-print-name thing))) (t (prin1 thing)))) (defun eieio-list-prin1 (list) @@ -859,64 +938,42 @@ this object." ;;; Unimplemented functions from CLOS ;; -(defun change-class (obj class) +(defun change-class (_obj _class) "Change the class of OBJ to type CLASS. This may create or delete slots, but does not affect the return value of `eq'." (error "EIEIO: `change-class' is unimplemented")) +;; Hook ourselves into help system for describing classes and methods. +;; FIXME: This is not actually needed any more since we can click on the +;; hyperlink from the constructor's docstring to see the type definition. +(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) + ;;; Interfacing with edebug ;; -(defun eieio-edebug-prin1-to-string (object &optional noescape) +(defun eieio-edebug-prin1-to-string (print-function object &optional noescape) "Display EIEIO OBJECT in fancy format. -Overrides the edebug default. -Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." - (cond ((class-p object) (eieio-class-name object)) + +Used as advice around `edebug-prin1-to-string', held in the +variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to +`prin1-to-string' when appropriate." + (cond ((eieio--class-p object) (eieio--class-print-name object)) ((eieio-object-p object) (object-print object)) - ((and (listp object) (or (class-p (car object)) + ((and (listp object) (or (eieio--class-p (car object)) (eieio-object-p (car object)))) - (concat "(" (mapconcat 'eieio-edebug-prin1-to-string object " ") ")")) - (t (prin1-to-string object noescape)))) - -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec defmethod - (&define ; this means we are defining something - [&or name ("setf" :name setf name)] - ;; ^^ This is the methods symbol - [ &optional symbolp ] ; this is key :before etc - list ; arguments - [ &optional stringp ] ; documentation string - def-body ; part to be debugged - )) - ;; The rest of the macros - (def-edebug-spec oref (form quote)) - (def-edebug-spec oref-default (form quote)) - (def-edebug-spec oset (form quote form)) - (def-edebug-spec oset-default (form quote form)) - (def-edebug-spec class-v form) - (def-edebug-spec class-p form) - (def-edebug-spec eieio-object-p form) - (def-edebug-spec class-constructor form) - (def-edebug-spec generic-p form) - (def-edebug-spec with-slots (list list def-body)) - ;; I suspect this isn't the best way to do this, but when - ;; cust-print was used on my system all my objects - ;; appeared as "#1 =" which was not useful. This allows - ;; edebug to print my objects in the nice way they were - ;; meant to with `object-print' and `class-name' - ;; (defalias 'edebug-prin1-to-string 'eieio-edebug-prin1-to-string) - ) - ) - -;;; Autoloading some external symbols, and hooking into the help system -;; + (concat "(" (mapconcat + (lambda (x) (eieio-edebug-prin1-to-string print-function x)) + object " ") + ")")) + (t (funcall print-function object noescape)))) + +(advice-add 'edebug-prin1-to-string + :around #'eieio-edebug-prin1-to-string) ;;; Start of automatically extracted autoloads. -;;;### (autoloads (customize-object) "eieio-custom" "eieio-custom.el" -;;;;;; "928623502e8bf40454822355388542b5") +;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "916f54b818479a77a02f3ecccda84a11") ;;; Generated autoloads from eieio-custom.el (autoload 'customize-object "eieio-custom" "\ @@ -927,9 +984,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" "d00419c898056fadf2f8e491f864aa1e") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ @@ -938,33 +993,13 @@ 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. -If CLASS is actually an object, then also display current values of that object. -Optional HEADERFCN should be called to insert a few bits of info first. - -\(fn CLASS &optional HEADERFCN)" t nil) - -(autoload 'eieio-describe-constructor "eieio-opt" "\ -Describe the constructor function FCN. -Uses `eieio-describe-class' to describe the class being constructed. - -\(fn FCN)" t nil) -(defalias 'describe-generic 'eieio-describe-generic) - -(autoload 'eieio-describe-generic "eieio-opt" "\ -Describe the generic function GENERIC. -Also extracts information about all methods specific to this generic. -\(fn GENERIC)" t nil) +(define-obsolete-function-alias 'eieio-help-class 'cl--describe-class "25.1") -(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-constructor "eieio-opt" "\ +Describe CTR if it is a class constructor. -\(fn &rest UNUSED)" nil nil) +\(fn CTR)" nil nil) ;;;*** diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 4efbdcb22cb..bbc8e153f74 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-2015 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 @@ -46,8 +47,6 @@ ;;; Code: -(require 'help-fns) ;For fundoc-usage handling functions. - (defgroup eldoc nil "Show function arglist or variable docstring in echo area." :group 'lisp @@ -62,24 +61,31 @@ 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." :type '(choice string (const :tag "None" nil)) :group 'eldoc) -(defcustom eldoc-argument-case 'upcase +(defcustom eldoc-argument-case #'identity "Case to display argument names of functions, as a symbol. This has two preferred values: `upcase' or `downcase'. Actually, any name of a function which takes a string as an argument and returns another string is acceptable. -Note that if `eldoc-documentation-function' is non-nil, this variable -has no effect, unless the function handles it explicitly." +Note that this variable has no effect, unless +`eldoc-documentation-function' handles it explicitly." :type '(radio (function-item upcase) (function-item downcase) function) :group 'eldoc) +(make-obsolete-variable 'eldoc-argument-case nil "25.1") (defcustom eldoc-echo-area-use-multiline-p 'truncate-sym-name-if-fit "Allow long ElDoc messages to resize echo area display. @@ -96,8 +102,8 @@ If value is nil, messages are always truncated to fit in a single line of display in the echo area. Function or variable symbol name may be truncated to make more of the arglist or documentation string visible. -Note that if `eldoc-documentation-function' is non-nil, this variable -has no effect, unless the function handles it explicitly." +Note that this variable has no effect, unless +`eldoc-documentation-function' handles it explicitly." :type '(radio (const :tag "Always" t) (const :tag "Never" nil) (const :tag "Yes, but truncate symbol names if it will\ @@ -107,8 +113,8 @@ has no effect, unless the function handles it explicitly." (defface eldoc-highlight-function-argument '((t (:inherit bold))) "Face used for the argument at point in a function's argument list. -Note that if `eldoc-documentation-function' is non-nil, this face -has no effect, unless the function handles it explicitly." +Note that this face has no effect unless the `eldoc-documentation-function' +handles it explicitly." :group 'eldoc) ;;; No user options below here. @@ -120,7 +126,8 @@ choose to increase the number of buckets, you must do so before loading this file since the obarray is initialized at load time. Remember to keep it a prime number to improve hash performance.") -(defconst eldoc-message-commands +(defvar eldoc-message-commands + ;; Don't define as `defconst' since it would then go to (read-only) purespace. (make-vector eldoc-message-commands-table-size 0) "Commands after which it is appropriate to print in the echo area. ElDoc does not try to print function arglists, etc., after just any command, @@ -131,12 +138,14 @@ This variable contains an obarray of symbols; do not manipulate it directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.") ;; Not a constant. -(defconst eldoc-last-data (make-vector 3 nil) +(defvar eldoc-last-data (make-vector 3 nil) + ;; Don't define as `defconst' since it would then go to (read-only) purespace. "Bookkeeping; elements are as follows: 0 - contains the last symbol read from the buffer. 1 - contains the string last displayed in the echo area for variables, or argument string for functions. - 2 - 'function if function args, 'variable if variable documentation.") + 2 - `function' if function args, `variable' if variable documentation.") +(make-obsolete-variable 'eldoc-last-data "use your own instead" "25.1") (defvar eldoc-last-message nil) @@ -146,10 +155,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 +(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 @@ -166,41 +185,50 @@ it displays the argument list of the function called in the expression point is on." :group 'eldoc :lighter eldoc-minor-mode-string (setq eldoc-last-message nil) - (if eldoc-mode - (progn - (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))) + (cond + ((memq eldoc-documentation-function '(nil ignore)) + (message "There is no ElDoc support in this buffer") + (setq eldoc-mode nil)) + (eldoc-mode + (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 nil t)) + (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 -(define-minor-mode eldoc-post-insert-mode nil - :group 'eldoc :lighter (:eval (if eldoc-mode "" - (concat eldoc-minor-mode-string "|i"))) +(define-minor-mode global-eldoc-mode + "Enable `eldoc-mode' in all buffers where it's applicable." + :group 'eldoc :global t + :initialize 'custom-initialize-delay + :init-value t (setq eldoc-last-message nil) - (let ((prn-info (lambda () - (unless eldoc-mode - (eldoc-print-current-symbol-info))))) - (if eldoc-post-insert-mode - (add-hook 'post-self-insert-hook prn-info nil t) - (remove-hook 'post-self-insert-hook prn-info t)))) - -(add-hook 'eval-expression-minibuffer-setup-hook 'eldoc-post-insert-mode) + (if global-eldoc-mode + (progn + (add-hook 'post-command-hook #'eldoc-schedule-timer) + (add-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area)) + (remove-hook 'post-command-hook #'eldoc-schedule-timer) + (remove-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area))) ;;;###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)) + (memq eldoc-timer timer-idle-list)) ;FIXME: Why? (setq eldoc-timer (run-with-idle-timer - eldoc-idle-delay t - (lambda () (and eldoc-mode (eldoc-print-current-symbol-info)))))) + eldoc-idle-delay nil + (lambda () + (when (or eldoc-mode + (and global-eldoc-mode + (not (memq eldoc-documentation-function + '(nil ignore))))) + (eldoc-print-current-symbol-info)))))) ;; If user has changed the idle delay, update the timer. (cond ((not (= eldoc-idle-delay eldoc-current-idle-delay)) @@ -215,6 +243,11 @@ expression point is on." Otherwise work like `message'." (if (minibufferp) (progn + (add-hook 'minibuffer-exit-hook + (lambda () (setq eldoc-mode-line-string nil + ;; http://debbugs.gnu.org/16920 + eldoc-last-message nil)) + nil t) (with-current-buffer (window-buffer (or (window-in-direction 'above (minibuffer-window)) @@ -225,17 +258,11 @@ Otherwise work like `message'." (setq mode-line-format (list "" '(eldoc-mode-line-string (" " eldoc-mode-line-string " ")) - mode-line-format)))) - (add-hook 'minibuffer-exit-hook - (lambda () (setq eldoc-mode-line-string nil)) - nil t) - (cond - ((null format-string) - (setq eldoc-mode-line-string nil)) - ((stringp format-string) - (setq eldoc-mode-line-string - (apply 'format format-string args)))) - (force-mode-line-update)) + mode-line-format))) + (setq eldoc-mode-line-string + (when (stringp format-string) + (apply #'format-message format-string args))) + (force-mode-line-update))) (apply 'message format-string args))) (defun eldoc-message (&rest args) @@ -247,7 +274,7 @@ Otherwise work like `message'." ;; eldoc-last-message so eq test above might succeed on ;; subsequent calls. ((null (cdr args)) (car args)) - (t (apply 'format args)))) + (t (apply #'format-message args)))) ;; In emacs 19.29 and later, and XEmacs 19.13 and later, all messages ;; are recorded in a log. Do not put eldoc messages in that log since ;; they are Legion. @@ -258,6 +285,10 @@ Otherwise work like `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 @@ -266,8 +297,12 @@ Otherwise work like `message'." ;; 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. @@ -277,22 +312,19 @@ Otherwise work like `message'." ;; 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)))) + (not (or executing-kbd-macro (bound-and-true-p edebug-active)))) ;;;###autoload -(defvar eldoc-documentation-function nil - "If non-nil, function to call to return doc string. +(defvar eldoc-documentation-function #'ignore + "Function to call to return doc string. The function of no args should return a one-line string for displaying doc about a function etc. appropriate to the context around point. It should return nil if there's no doc appropriate for the context. @@ -304,252 +336,50 @@ the variables `eldoc-argument-case' and `eldoc-echo-area-use-multiline-p', and the face `eldoc-highlight-function-argument', if they are to have any effect. -This variable is expected to be made buffer-local by modes (other than -Emacs Lisp mode) that support ElDoc.") +Major modes should modify this variable using `add-function', for example: + (add-function :before-until (local \\='eldoc-documentation-function) + #\\='foo-mode-eldoc-function) +so that the global documentation function (i.e. the default value of the +variable) is taken into account if the major mode specific function does not +return any documentation.") (defun eldoc-print-current-symbol-info () - (condition-case err - (and (or (eldoc-display-message-p) eldoc-post-insert-mode) - (if eldoc-documentation-function - (eldoc-message (funcall eldoc-documentation-function)) - (let* ((current-symbol (eldoc-current-symbol)) - (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)))) - -(defun eldoc-get-fnsym-args-string (sym &optional index) - "Return a string containing the parameter list of the function SYM. -If SYM is a subr and no arglist is obtainable from the docstring -or elsewhere, return a 1-line docstring. Calls the functions -`eldoc-function-argstring-format' and -`eldoc-highlight-function-argument' to format the result. The -former calls `eldoc-argument-case'; the latter gives the -function name `font-lock-function-name-face', and optionally -highlights argument number INDEX." - (let (args doc advertised) - (cond ((not (and sym (symbolp sym) (fboundp sym)))) - ((and (eq sym (aref eldoc-last-data 0)) - (eq 'function (aref eldoc-last-data 2))) - (setq doc (aref eldoc-last-data 1))) - ((listp (setq advertised (gethash (indirect-function sym) - advertised-signature-table t))) - (setq args advertised)) - ((setq doc (help-split-fundoc (documentation sym t) sym)) - (setq args (car doc)) - ;; Remove any enclosing (), since e-function-argstring adds them. - (string-match "\\`[^ )]* ?" args) - (setq args (substring args (match-end 0))) - (if (string-match-p ")\\'" args) - (setq args (substring args 0 -1)))) - (t - (setq args (help-function-arglist sym)))) - (if args - ;; Stringify, and store before highlighting, downcasing, etc. - ;; FIXME should truncate before storing. - (eldoc-last-data-store sym (setq args (eldoc-function-argstring args)) - 'function) - (setq args doc)) ; use stored value - ;; Change case, highlight, truncate. - (if args - (eldoc-highlight-function-argument - sym (eldoc-function-argstring-format args) index)))) - -(defun eldoc-highlight-function-argument (sym args index) - "Highlight argument INDEX in ARGS list for function SYM. -In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." - (let ((start nil) - (end 0) - (argument-face 'eldoc-highlight-function-argument)) - ;; Find the current argument in the argument string. We need to - ;; handle `&rest' and informal `...' properly. - ;; - ;; FIXME: What to do with optional arguments, like in - ;; (defun NAME ARGLIST [DOCSTRING] BODY...) case? - ;; The problem is there is no robust way to determine if - ;; the current argument is indeed a docstring. - (while (and index (>= index 1)) - (if (string-match "[^ ()]+" args end) - (progn - (setq start (match-beginning 0) - end (match-end 0)) - (let ((argument (match-string 0 args))) - (cond ((string= argument "&rest") - ;; All the rest arguments are the same. - (setq index 1)) - ((string= argument "&optional")) - ((string-match-p "\\.\\.\\.$" argument) - (setq index 0)) - (t - (setq index (1- index)))))) - (setq end (length args) - start (1- end) - argument-face 'font-lock-warning-face - index 0))) - (let ((doc args)) - (when start - (setq doc (copy-sequence args)) - (add-text-properties start end (list 'face argument-face) doc)) - (setq doc (eldoc-docstring-format-sym-doc - sym doc (if (functionp sym) 'font-lock-function-name-face - 'font-lock-keyword-face))) - doc))) - -;; Return a string containing a brief (one-line) documentation string for -;; the variable. -(defun eldoc-get-var-docstring (sym) - (when sym - (cond ((and (eq sym (aref eldoc-last-data 0)) - (eq 'variable (aref eldoc-last-data 2))) - (aref eldoc-last-data 1)) - (t - (let ((doc (documentation-property sym 'variable-documentation t))) - (cond (doc - (setq doc (eldoc-docstring-format-sym-doc - sym (eldoc-docstring-first-line doc) - 'font-lock-variable-name-face)) - (eldoc-last-data-store sym doc 'variable))) - doc))))) - -(defun eldoc-last-data-store (symbol doc type) - (aset eldoc-last-data 0 symbol) - (aset eldoc-last-data 1 doc) - (aset eldoc-last-data 2 type)) - -;; Note that any leading `*' in the docstring (which indicates the variable -;; is a user option) is removed. -(defun eldoc-docstring-first-line (doc) - (and (stringp doc) - (substitute-command-keys - (save-match-data - ;; Don't use "^" in the regexp below since it may match - ;; anywhere in the doc-string. - (let ((start (if (string-match "\\`\\*" doc) (match-end 0) 0))) - (cond ((string-match "\n" doc) - (substring doc start (match-beginning 0))) - ((zerop start) doc) - (t (substring doc start)))))))) + ;; 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)) + (eldoc-message (funcall eldoc-documentation-function))))) ;; If the entire line cannot fit in the echo area, the symbol name may be ;; truncated or eliminated entirely from the output to make room for the ;; description. -(defun eldoc-docstring-format-sym-doc (sym doc face) - (save-match-data - (let* ((name (symbol-name sym)) - (ea-multi eldoc-echo-area-use-multiline-p) - ;; Subtract 1 from window width since emacs will not write - ;; any chars to the last column, or in later versions, will - ;; cause a wraparound and resize of the echo area. - (ea-width (1- (window-width (minibuffer-window)))) - (strip (- (+ (length name) (length ": ") (length doc)) ea-width))) - (cond ((or (<= strip 0) - (eq ea-multi t) - (and ea-multi (> (length doc) ea-width))) - (format "%s: %s" (propertize name 'face face) doc)) - ((> (length doc) ea-width) - (substring (format "%s" doc) 0 ea-width)) - ((>= strip (length name)) - (format "%s" doc)) - (t - ;; Show the end of the partial symbol name, rather - ;; than the beginning, since the former is more likely - ;; to be unique given package namespace conventions. - (setq name (substring name strip)) - (format "%s: %s" (propertize name 'face face) doc)))))) - - -;; Return a list of current function name and argument index. -(defun eldoc-fnsym-in-current-sexp () - (save-excursion - (let ((argument-index (1- (eldoc-beginning-of-sexp)))) - ;; If we are at the beginning of function name, this will be -1. - (when (< argument-index 0) - (setq argument-index 0)) - ;; Don't do anything if current word is inside a string. - (if (= (or (char-after (1- (point))) 0) ?\") - nil - (list (eldoc-current-symbol) argument-index))))) - -;; Move to the beginning of current sexp. Return the number of nested -;; sexp the point was over or after. -(defun eldoc-beginning-of-sexp () - (let ((parse-sexp-ignore-comments t) - (num-skipped-sexps 0)) - (condition-case err - (progn - ;; First account for the case the point is directly over a - ;; beginning of a nested sexp. - (condition-case err - (let ((p (point))) - (forward-sexp -1) - (forward-sexp 1) - (when (< (point) p) - (setq num-skipped-sexps 1))) - (error)) - (while - (let ((p (point))) - (forward-sexp -1) - (when (< (point) p) - (setq num-skipped-sexps (1+ num-skipped-sexps)))))) - (error)) - num-skipped-sexps)) - -;; returns nil unless current word is an interned symbol. -(defun eldoc-current-symbol () - (let ((c (char-after (point)))) - (and c - (memq (char-syntax c) '(?w ?_)) - (intern-soft (current-word))))) - -;; Do indirect function resolution if possible. -(defun eldoc-symbol-function (fsym) - (let ((defn (and (fboundp fsym) - (symbol-function fsym)))) - (and (symbolp defn) - (condition-case err - (setq defn (indirect-function fsym)) - (error (setq defn nil)))) - defn)) - -(defun eldoc-function-argstring (arglist) - "Return ARGLIST as a string enclosed by (). -ARGLIST is either a string, or a list of strings or symbols." - (cond ((stringp arglist)) - ((not (listp arglist)) - (setq arglist nil)) - ((symbolp (car arglist)) - (setq arglist - (mapconcat (lambda (s) (symbol-name s)) - arglist " "))) - ((stringp (car arglist)) - (setq arglist - (mapconcat (lambda (s) s) - arglist " ")))) - (if arglist - (format "(%s)" arglist))) - -(defun eldoc-function-argstring-format (argstring) - "Apply `eldoc-argument-case' to each word in ARGSTRING. -The words \"&rest\", \"&optional\" are returned unchanged." - (mapconcat (lambda (s) - (if (string-match-p "\\`(?&\\(?:optional\\|rest\\))?\\'" s) - s - (funcall eldoc-argument-case s))) - (split-string argstring) " ")) +(defun eldoc-docstring-format-sym-doc (prefix doc &optional face) + (when (symbolp prefix) + (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": "))) + (let* ((ea-multi eldoc-echo-area-use-multiline-p) + ;; Subtract 1 from window width since emacs will not write + ;; any chars to the last column, or in later versions, will + ;; cause a wraparound and resize of the echo area. + (ea-width (1- (window-width (minibuffer-window)))) + (strip (- (+ (length prefix) (length doc)) ea-width))) + (cond ((or (<= strip 0) + (eq ea-multi t) + (and ea-multi (> (length doc) ea-width))) + (concat prefix doc)) + ((> (length doc) ea-width) + (substring (format "%s" doc) 0 ea-width)) + ((>= strip (string-match-p ":? *\\'" prefix)) + doc) + (t + ;; Show the end of the partial symbol name, rather + ;; than the beginning, since the former is more likely + ;; to be unique given package namespace conventions. + (concat (substring prefix strip) doc))))) - ;; When point is in a sexp, the function args are not reprinted in the echo ;; area after every possible interactive command because some of them print ;; their own messages in the echo area; the eldoc functions would instantly @@ -564,7 +394,7 @@ The words \"&rest\", \"&optional\" are returned unchanged." (defun eldoc-add-command-completions (&rest names) (dolist (name names) - (apply 'eldoc-add-command (all-completions name obarray 'commandp)))) + (apply #'eldoc-add-command (all-completions name obarray 'commandp)))) (defun eldoc-remove-command (&rest cmds) (dolist (name cmds) @@ -574,12 +404,13 @@ The words \"&rest\", \"&optional\" are returned unchanged." (defun eldoc-remove-command-completions (&rest names) (dolist (name names) - (apply 'eldoc-remove-command + (apply #'eldoc-remove-command (all-completions name eldoc-message-commands)))) ;; Prime the command list. (eldoc-add-command-completions + "back-to-indentation" "backward-" "beginning-of-" "delete-other-windows" "delete-window" "down-list" "end-of-" "exchange-point-and-mark" "forward-" "goto-" "handle-select-window" "indent-for-tab-command" "left-" "mark-page" diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 7998f732f06..64d65c05902 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-2015 Free Software Foundation, Inc. ;; Author: Peter Liljenberg <petli@lysator.liu.se> ;; Created: May 1997 @@ -46,8 +46,6 @@ ;;; Code: -(require 'help-fns) - (defgroup elint nil "Linting for Emacs Lisp." :prefix "elint-" @@ -251,9 +249,9 @@ This environment can be passed to `macroexpand'." (elint-set-mode-line t) (with-current-buffer elint-log-buffer (unless (string-equal default-directory dir) - (elint-log-message (format " \nLeaving directory `%s'" - default-directory) t) - (elint-log-message (format "Entering directory `%s'" dir) t) + (elint-log-message (format-message " \nLeaving directory `%s'" + default-directory) t) + (elint-log-message (format-message "Entering directory `%s'" dir) t) (setq default-directory dir)))) (let ((str (format "Linting file %s" file))) (message "%s..." str) @@ -374,9 +372,9 @@ Returns the forms." (let ((elint-current-pos (point))) ;; non-list check could be here too. errors may be out of seq. ;; quoted check cannot be elsewhere, since quotes skipped. - (if (looking-back "'") + (if (looking-back "'" (1- (point))) ;; Eg cust-print.el uses ' as a comment syntax. - (elint-warning "Skipping quoted form `'%.20s...'" + (elint-warning "Skipping quoted form `%c%.20s...'" ?\' (read (current-buffer))) (condition-case nil (setq tops (cons @@ -385,7 +383,7 @@ Returns the forms." tops)) (end-of-file (goto-char elint-current-pos) - (error "Missing ')' in top form: %s" + (error "Missing `)' in top form: %s" (buffer-substring elint-current-pos (line-end-position)))))))) (nreverse tops)))) @@ -522,7 +520,7 @@ Return nil if there are no more forms, t otherwise." ;;; (with-syntax-table emacs-lisp-mode-syntax-table ;;; (elint-update-env)) ;;; (setq env (elint-env-add-env env elint-buffer-env)))) - ;;(message "Elint processed (require '%s)" name)) + ;;(message "%s" (format "Elint processed (require '%s)" name)) (error "%s.el not found in load-path" libname))) (error (message "Can't get variables from require'd library %s: %s" @@ -984,7 +982,7 @@ Does basic handling of `featurep' tests." (line-beginning-position)))) 0) ; unknown position type - (apply 'format string args)))) + (apply #'format-message string args)))) (defun elint-error (string &rest args) "Report a linting error. @@ -1145,8 +1143,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..39d62ad34a0 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-2015 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..f899f40fb80 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-2015 Free Software Foundation, Inc. ;; Author: Lennart Borgman (lennart O borgman A gmail O com) ;; Christian Ohler <ohler@gnu.org> @@ -137,7 +137,7 @@ the name of the test and the result of NAME-FORM." This effectively executes - \(apply (car COMMAND) (cdr COMMAND)\) + (apply (car COMMAND) (cdr COMMAND)) and returns the same value, but additionally runs hooks like `pre-command-hook' and `post-command-hook', and sets variables @@ -189,7 +189,7 @@ test for `called-interactively' in the command will fail." "Return a copy of S with all matches of REGEXPS removed. Elements of REGEXPS may also be two-element lists \(REGEXP -SUBEXP\), where SUBEXP is the number of a subexpression in +SUBEXP), where SUBEXP is the number of a subexpression in REGEXP. In that case, only that subexpression will be removed rather than the entire match." ;; Use a temporary buffer since replace-match copies strings, which @@ -214,8 +214,8 @@ property list, or no properties if there is no plist before it. As a simple example, -\(ert-propertized-string \"foo \" '(face italic) \"bar\" \" baz\" nil \ -\" quux\"\) +\(ert-propertized-string \"foo \" \\='(face italic) \"bar\" \" baz\" nil \ +\" quux\") would return the string \"foo bar baz quux\" where the substring \"bar baz\" has a `face' property with the value `italic'. diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 98576687f3d..21c1f1be394 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-2015 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 @@ -61,7 +64,7 @@ (require 'ewoc) (require 'find-func) (require 'help) - +(require 'pp) ;;; UI customization options. @@ -174,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. @@ -184,7 +187,7 @@ using :expected-result. See `ert-test-result-type-p' for a description of valid values for RESULT-TYPE. \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ -\[:tags '(TAG...)] BODY...)" +[:tags '(TAG...)] BODY...)" (declare (debug (&define :name test name sexp [&optional stringp] [&rest keywordp sexp] def-body)) @@ -200,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 @@ -237,6 +240,7 @@ description of valid values for RESULT-TYPE. (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." @@ -247,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. @@ -260,7 +269,7 @@ DATA is displayed to the user and should state the reason of the failure." (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." (and (symbolp thing) - (let ((definition (indirect-function thing t))) + (let ((definition (indirect-function thing))) (and (subrp definition) (eql (cdr (subr-arity definition)) 'unevalled))))) @@ -425,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. @@ -644,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))) @@ -728,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))) @@ -737,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 @@ -785,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)) ;; { @@ -798,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 @@ -818,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 @@ -837,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)) @@ -861,11 +886,11 @@ Valid result types: nil -- Never matches. t -- Always matches. -:failed, :passed -- Matches corresponding results. -\(and TYPES...\) -- Matches if all TYPES match. -\(or TYPES...\) -- Matches if some TYPES match. -\(not TYPE\) -- Matches if TYPE does not match. -\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with +: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. +\(satisfies PREDICATE) -- Matches if PREDICATE returns true when called with RESULT." ;; It would be easy to add `member' and `eql' types etc., but I ;; haven't bothered yet. @@ -874,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 @@ -898,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. @@ -918,7 +946,7 @@ a test -- (i.e., an object of the ert-test data-type) Selects that test. a symbol -- Selects the test that the symbol names, errors if none. \(member TESTS...) -- Selects the elements of TESTS, a list of tests or symbols naming tests. -\(eql TEST\) -- Selects TEST, a test or a symbol naming a test. +\(eql TEST) -- Selects TEST, a test or a symbol naming a test. \(and SELECTORS...) -- Selects the tests that match all SELECTORS. \(or SELECTORS...) -- Selects the tests that match any of the SELECTORS. \(not SELECTOR) -- Selects all tests that do not match SELECTOR. @@ -971,7 +999,8 @@ contained in UNIVERSE." (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 @@ -1084,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) @@ -1102,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." @@ -1137,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)) @@ -1145,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))))) @@ -1239,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")))) @@ -1251,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"))))) @@ -1259,7 +1300,8 @@ EXPECTEDP specifies whether the result was expected." (defun ert--pp-with-indentation-and-newline (object) "Pretty-print OBJECT, indenting it to the current column of point. Ensures a final newline is inserted." - (let ((begin (point))) + (let ((begin (point)) + (pp-escape-newlines nil)) (pp object (current-buffer)) (unless (bolp) (insert "\n")) (save-excursion @@ -1279,7 +1321,7 @@ RESULT must be an `ert-test-result-with-condition'." (unwind-protect (progn (insert message "\n") - (setq end (copy-marker (point))) + (setq end (point-marker)) (goto-char begin) (insert " " prefix) (forward-line 1) @@ -1317,8 +1359,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: ") @@ -1327,6 +1370,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) "" @@ -1339,6 +1385,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 ) @@ -1409,13 +1464,72 @@ the tests)." (kill-emacs 2)))) +(defun ert-summarize-tests-batch-and-exit () + "Summarize the results of testing. +Expects to be called in batch mode, with logfiles as command-line arguments. +The logfiles should have the `ert-run-tests-batch' format. When finished, +this exits Emacs, with status as per `ert-run-tests-batch-and-exit'." + (or noninteractive + (user-error "This function is only for use in batch mode")) + (let ((nlogs (length command-line-args-left)) + (ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0) + nnotrun logfile notests badtests unexpected) + (with-temp-buffer + (while (setq logfile (pop command-line-args-left)) + (erase-buffer) + (insert-file-contents logfile) + (if (not (re-search-forward "^Running \\([0-9]+\\) tests" nil t)) + (push logfile notests) + (setq ntests (+ ntests (string-to-number (match-string 1)))) + (if (not (re-search-forward "^\\(Aborted: \\)?\ +Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ +\\(?:, \\([0-9]+\\) unexpected\\)?\ +\\(?:, \\([0-9]+\\) skipped\\)?" nil t)) + (push logfile badtests) + (if (match-string 1) (push logfile badtests)) + (setq nrun (+ nrun (string-to-number (match-string 2))) + nexpected (+ nexpected (string-to-number (match-string 3)))) + (when (match-string 4) + (push logfile unexpected) + (setq nunexpected (+ nunexpected + (string-to-number (match-string 4))))) + (if (match-string 5) + (setq nskipped (+ nskipped + (string-to-number (match-string 5))))))))) + (setq nnotrun (- ntests nrun)) + (message "\nSUMMARY OF TEST RESULTS") + (message "-----------------------") + (message "Files examined: %d" nlogs) + (message "Ran %d tests%s, %d results as expected%s%s" + nrun + (if (zerop nnotrun) "" (format ", %d failed to run" nnotrun)) + nexpected + (if (zerop nunexpected) + "" + (format ", %d unexpected" nunexpected)) + (if (zerop nskipped) + "" + (format ", %d skipped" nskipped))) + (when notests + (message "%d files did not contain any tests:" (length notests)) + (mapc (lambda (l) (message " %s" l)) notests)) + (when badtests + (message "%d files did not finish:" (length badtests)) + (mapc (lambda (l) (message " %s" l)) badtests)) + (when unexpected + (message "%d files contained unexpected results:" (length unexpected)) + (mapc (lambda (l) (message " %s" l)) unexpected)) + (kill-emacs (cond ((or notests badtests (not (zerop nnotrun))) 2) + (unexpected 1) + (t 0))))) + ;;; Utility functions for load/unload actions. (defun ert--activate-font-lock-keywords () "Activate font-lock keywords for some of ERT's symbols." (font-lock-add-keywords nil - '(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\sw+\\)?" + '(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\(?:\\sw\\|\\s_\\)+\\)?" (1 font-lock-keyword-face nil t) (2 font-lock-function-name-face nil t))))) @@ -1561,15 +1675,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 @@ -1734,7 +1850,9 @@ non-nil, returns the face for expected results.." (when (ert-test-documentation test) (insert " " (propertize - (ert--string-first-line (ert-test-documentation test)) + (ert--string-first-line + (substitute-command-keys + (ert-test-documentation test))) 'font-lock-face 'font-lock-doc-face) "\n")) (cl-etypecase result @@ -1826,11 +1944,12 @@ 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)) + (read + (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) @@ -1849,7 +1968,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: ") @@ -1859,7 +1978,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))) @@ -2254,9 +2378,9 @@ To be used in the ERT results buffer." (ert--print-backtrace backtrace) (debugger-make-xrefs) (goto-char (point-min)) - (insert "Backtrace for test `") + (insert (substitute-command-keys "Backtrace for test `")) (ert-insert-test-name-button (ert-test-name test)) - (insert "':\n"))))))) + (insert (substitute-command-keys "':\n")))))))) (defun ert-results-pop-to-messages-for-test-at-point () "Display the part of the *Messages* buffer generated during the test at point. @@ -2275,9 +2399,9 @@ To be used in the ERT results buffer." (ert-simple-view-mode) (insert (ert-test-result-messages result)) (goto-char (point-min)) - (insert "Messages for test `") + (insert (substitute-command-keys "Messages for test `")) (ert-insert-test-name-button (ert-test-name test)) - (insert "':\n"))))) + (insert (substitute-command-keys "':\n")))))) (defun ert-results-pop-to-should-forms-for-test-at-point () "Display the list of `should' forms executed during the test at point. @@ -2305,9 +2429,10 @@ To be used in the ERT results buffer." (ert--pp-with-indentation-and-newline form-description) (ert--make-xrefs-region begin (point))))) (goto-char (point-min)) - (insert "`should' forms executed during test `") + (insert (substitute-command-keys + "`should' forms executed during test `")) (ert-insert-test-name-button (ert-test-name test)) - (insert "':\n") + (insert (substitute-command-keys "':\n")) (insert "\n") (insert (concat "(Values are shallow copies and may have " "looked different during the test if they\n" @@ -2384,9 +2509,11 @@ To be used in the ERT results buffer." (let ((file-name (and test-name (symbol-file test-name 'ert-deftest)))) (when file-name - (insert " defined in `" (file-name-nondirectory file-name) "'") + (insert (format-message " defined in `%s'" + (file-name-nondirectory file-name))) (save-excursion - (re-search-backward "`\\([^`']+\\)'" nil t) + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") + nil t) (help-xref-button 1 'help-function-def test-name file-name))) (insert ".") (fill-region-as-paragraph (point-min) (point)) @@ -2398,8 +2525,9 @@ To be used in the ERT results buffer." "this documentation refers to an old definition.") (fill-region-as-paragraph begin (point))) (insert "\n\n")) - (insert (or (ert-test-documentation test-definition) - "It is not documented.") + (insert (substitute-command-keys + (or (ert-test-documentation test-definition) + "It is not documented.")) "\n"))))))) (defun ert-results-describe-test-at-point () @@ -2416,7 +2544,7 @@ To be used in the ERT results buffer." (add-to-list 'minor-mode-alist '(ert--current-run-stats (:eval (ert--tests-running-mode-line-indicator)))) -(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) +(add-hook 'emacs-lisp-mode-hook #'ert--activate-font-lock-keywords) (defun ert--unload-function () "Unload function to undo the side-effects of loading ert.el." @@ -2427,7 +2555,7 @@ To be used in the ERT results buffer." nil) (defvar ert-unload-hook '()) -(add-hook 'ert-unload-hook 'ert--unload-function) +(add-hook 'ert-unload-hook #'ert--unload-function) (provide 'ert) diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index ffd17e5d7af..1f0c25e8205 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-2015 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..69d545560d4 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 +;;; find-func.el --- find the definition of the Emacs Lisp function near point -*- lexical-binding:t -*- -;; Copyright (C) 1997, 1999, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2015 Free Software Foundation, Inc. ;; Author: Jens Petersen <petersen@kurims.kyoto-u.ac.jp> ;; Maintainer: petersen@kurims.kyoto-u.ac.jp @@ -59,10 +59,10 @@ (concat "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ -foo\\|[^icfgv]\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ +foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ menu-bar-make-toggle\\)" find-function-space-re - "\\('\\|\(quote \\)?%s\\(\\s-\\|$\\|\(\\|\)\\)") + "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") "The regexp used by `find-function' to search for a function definition. Note it must contain a `%s' at the place where `format' should insert the function name. The default value avoids `defconst', @@ -100,13 +100,40 @@ Please send improvements and fixes to the maintainer." :group 'find-function :version "22.1") +(defcustom find-feature-regexp + (concat ";;; Code:") + "The regexp used by `xref-find-definitions' when searching for a feature definition. +Note it must contain a `%s' at the place where `format' +should insert the feature name." + ;; We search for ";;; Code" rather than (feature '%s) because the + ;; former is near the start of the code, and the latter is very + ;; uninteresting. If the regexp is not found, just goes to + ;; (point-min), which is acceptable in this case. + :type 'regexp + :group 'xref + :version "25.0") + +(defcustom find-alias-regexp + "(defalias +'%s" + "The regexp used by `xref-find-definitions' to search for an alias definition. +Note it must contain a `%s' at the place where `format' +should insert the feature name." + :type 'regexp + :group 'xref + :version "25.0") + (defvar find-function-regexp-alist '((nil . find-function-regexp) (defvar . find-variable-regexp) - (defface . find-face-regexp)) + (defface . find-face-regexp) + (feature . find-feature-regexp) + (defalias . find-alias-regexp)) "Alist mapping definition types into regexp variables. Each regexp variable's value should actually be a format string -to be used to substitute the desired symbol name into the regexp.") +to be used to substitute the desired symbol name into the regexp. +Instead of regexp variable, types can be mapped to functions as well, +in which case the function is called with one argument (the object +we're looking for) and it should search for it.") (put 'find-function-regexp-alist 'risky-local-variable t) (defcustom find-function-source-path nil @@ -178,8 +205,7 @@ LIBRARY should be a string (the name of the library)." (defvar find-function-C-source-directory (let ((dir (expand-file-name "src" source-directory))) - (when (and (file-directory-p dir) (file-readable-p dir)) - dir)) + (if (file-accessible-directory-p dir) dir)) "Directory where the C source files of Emacs can be found. If nil, do not try to find the source code of functions and variables defined in C.") @@ -187,12 +213,15 @@ defined in C.") (declare-function ad-get-advice-info "advice" (function)) (defun find-function-advised-original (func) - "Return the original function symbol of an advised function FUNC. -If FUNC is not the symbol of an advised function, just returns FUNC." + "Return the original function definition of an advised function FUNC. +If FUNC is not a symbol, return it. Else, if it's not advised, +return the symbol's function definition." (or (and (symbolp func) - (featurep 'advice) - (let ((ofunc (cdr (assq 'origname (ad-get-advice-info func))))) - (and (fboundp ofunc) ofunc))) + (featurep 'nadvice) + (let ((ofunc (advice--symbol-function func))) + (if (advice--p ofunc) + (advice--cd*r ofunc) + ofunc))) func)) (defun find-function-C-source (fun-or-var file type) @@ -219,7 +248,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)) @@ -283,35 +312,79 @@ The search is done in the source for library LIBRARY." (let* ((filename (find-library-name library)) (regexp-symbol (cdr (assq type find-function-regexp-alist)))) (with-current-buffer (find-file-noselect filename) - (let ((regexp (format (symbol-value regexp-symbol) - ;; Entry for ` (backquote) macro in loaddefs.el, - ;; (defalias (quote \`)..., has a \ but - ;; (symbol-name symbol) doesn't. Add an - ;; optional \ to catch this. - (concat "\\\\?" - (regexp-quote (symbol-name symbol))))) + (let ((regexp (if (functionp regexp-symbol) regexp-symbol + (format (symbol-value regexp-symbol) + ;; Entry for ` (backquote) macro in loaddefs.el, + ;; (defalias (quote \`)..., has a \ but + ;; (symbol-name symbol) doesn't. Add an + ;; optional \ to catch this. + (concat "\\\\?" + (regexp-quote (symbol-name symbol)))))) (case-fold-search)) (with-syntax-table emacs-lisp-mode-syntax-table (goto-char (point-min)) - (if (or (re-search-forward regexp nil t) - ;; `regexp' matches definitions using known forms like - ;; `defun', or `defvar'. But some functions/variables - ;; are defined using special macros (or functions), so - ;; if `regexp' can't find the definition, we look for - ;; something of the form "(SOMETHING <symbol> ...)". - ;; This fails to distinguish function definitions from - ;; variable declarations (or even uses thereof), but is - ;; a good pragmatic fallback. - (re-search-forward - (concat "^([^ ]+" find-function-space-re "['(]?" - (regexp-quote (symbol-name symbol)) - "\\_>") - nil t)) + (if (if (functionp regexp) + (funcall regexp symbol) + (or (re-search-forward regexp nil t) + ;; `regexp' matches definitions using known forms like + ;; `defun', or `defvar'. But some functions/variables + ;; are defined using special macros (or functions), so + ;; if `regexp' can't find the definition, we look for + ;; something of the form "(SOMETHING <symbol> ...)". + ;; This fails to distinguish function definitions from + ;; variable declarations (or even uses thereof), but is + ;; a good pragmatic fallback. + (re-search-forward + (concat "^([^ ]+" find-function-space-re "['(]?" + (regexp-quote (symbol-name symbol)) + "\\_>") + nil t))) (progn (beginning-of-line) (cons (current-buffer) (point))) (cons (current-buffer) nil)))))))) +(defun find-function-library (function &optional lisp-only verbose) + "Return the pair (ORIG-FUNCTION . LIBRARY) for FUNCTION. + +ORIG-FUNCTION is the original name, after removing all advice and +resolving aliases. LIBRARY is an absolute file name, a relative +file name inside the C sources directory, or a name of an +autoloaded feature. + +If ORIG-FUNCTION is a built-in function and LISP-ONLY is non-nil, +signal an error. + +If VERBOSE is non-nil, and FUNCTION is an alias, display a +message about the whole chain of aliases." + (let ((def (if (symbolp function) + (find-function-advised-original function))) + aliases) + ;; FIXME for completeness, it might be nice to print something like: + ;; foo (which is advised), which is an alias for bar (which is advised). + (while (and def (symbolp def)) + (or (eq def function) + (not verbose) + (setq aliases (if aliases + (concat aliases + (format-message + ", which is an alias for `%s'" + (symbol-name def))) + (format-message "`%s' is an alias for `%s'" + function (symbol-name def))))) + (setq function (find-function-advised-original function) + def (find-function-advised-original function))) + (if aliases + (message "%s" aliases)) + (cons function + (cond + ((autoloadp def) (nth 1 def)) + ((subrp def) + (if lisp-only + (error "%s is a built-in function" function)) + (help-C-file-name def 'subr)) + ((symbol-file function 'defun)))))) + ;;;###autoload (defun find-function-noselect (function &optional lisp-only) "Return a pair (BUFFER . POINT) pointing to the definition of FUNCTION. @@ -330,30 +403,8 @@ searched for in `find-function-source-path' if non-nil, otherwise in `load-path'." (if (not function) (error "You didn't specify a function")) - (let ((def (symbol-function (find-function-advised-original function))) - aliases) - ;; FIXME for completeness, it might be nice to print something like: - ;; foo (which is advised), which is an alias for bar (which is advised). - (while (symbolp def) - (or (eq def function) - (if aliases - (setq aliases (concat aliases - (format ", which is an alias for `%s'" - (symbol-name def)))) - (setq aliases (format "`%s' is an alias for `%s'" - function (symbol-name def))))) - (setq function (symbol-function (find-function-advised-original function)) - def (symbol-function (find-function-advised-original function)))) - (if aliases - (message "%s" aliases)) - (let ((library - (cond ((autoloadp def) (nth 1 def)) - ((subrp def) - (if lisp-only - (error "%s is a built-in function" function)) - (help-C-file-name def 'subr)) - ((symbol-file function 'defun))))) - (find-function-search-for-symbol function nil library)))) + (let ((func-lib (find-function-library function lisp-only t))) + (find-function-search-for-symbol (car func-lib) nil (cdr func-lib)))) (defun find-function-read (&optional type) "Read and return an interned symbol, defaulting to the one near point. @@ -392,7 +443,6 @@ See also `find-function-after-hook'. Set mark before moving, if the buffer already existed." (let* ((orig-point (point)) - (orig-buf (window-buffer)) (orig-buffers (buffer-list)) (buffer-point (save-excursion (find-definition-noselect symbol type))) @@ -525,11 +575,11 @@ See also `find-function-recenter-line' and `find-function-after-hook'." (interactive (find-function-read 'defface)) (find-function-do-it face 'defface 'switch-to-buffer)) -;;;###autoload -(defun find-function-on-key (key) +(defun find-function-on-key-do-it (key find-fn) "Find the function that KEY invokes. KEY is a string. -Set mark before moving, if the buffer already existed." - (interactive "kFind function on key: ") +Set mark before moving, if the buffer already existed. + +FIND-FN is the function to call to navigate to the function." (let (defn) (save-excursion (let* ((event (and (eventp key) (aref key 0))) ; Null event OK below. @@ -550,7 +600,28 @@ Set mark before moving, if the buffer already existed." (message "%s is unbound" key-desc) (if (consp defn) (message "%s runs %s" key-desc (prin1-to-string defn)) - (find-function-other-window defn)))))) + (funcall find-fn defn)))))) + +;;;###autoload +(defun find-function-on-key (key) + "Find the function that KEY invokes. KEY is a string. +Set mark before moving, if the buffer already existed." + (interactive "kFind function on key: ") + (find-function-on-key-do-it key #'find-function)) + +;;;###autoload +(defun find-function-on-key-other-window (key) + "Find, in the other window, the function that KEY invokes. +See `find-function-on-key'." + (interactive "kFind function on key: ") + (find-function-on-key-do-it key #'find-function-other-window)) + +;;;###autoload +(defun find-function-on-key-other-frame (key) + "Find, in the other frame, the function that KEY invokes. +See `find-function-on-key'." + (interactive "kFind function on key: ") + (find-function-on-key-do-it key #'find-function-other-frame)) ;;;###autoload (defun find-function-at-point () @@ -575,6 +646,8 @@ Set mark before moving, if the buffer already existed." (define-key ctl-x-4-map "F" 'find-function-other-window) (define-key ctl-x-5-map "F" 'find-function-other-frame) (define-key ctl-x-map "K" 'find-function-on-key) + (define-key ctl-x-4-map "K" 'find-function-on-key-other-window) + (define-key ctl-x-5-map "K" 'find-function-on-key-other-frame) (define-key ctl-x-map "V" 'find-variable) (define-key ctl-x-4-map "V" 'find-variable-other-window) (define-key ctl-x-5-map "V" 'find-variable-other-frame)) diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el deleted file mode 100644 index 82b3e94bb4d..00000000000 --- a/lisp/emacs-lisp/find-gc.el +++ /dev/null @@ -1,161 +0,0 @@ -;;; find-gc.el --- detect functions that call the garbage collector - -;; Copyright (C) 1992, 2001-2013 Free Software Foundation, Inc. - -;; Maintainer: FSF - -;; 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: - -;; Produce in find-gc-unsafe-list the set of all functions that may invoke GC. -;; This expects the Emacs sources to live in find-gc-source-directory. -;; It creates a temporary working directory /tmp/esrc. - -;;; Code: - -(defvar find-gc-unsafe-list nil - "The list of unsafe functions is placed here by `find-gc-unsafe'.") - -(defvar find-gc-source-directory) - -(defvar find-gc-subrs-callers nil - "Alist of users of subrs, from GC testing. -Each entry has the form (FUNCTION . FUNCTIONS-THAT-CALL-IT).") - -(defvar find-gc-subrs-called nil - "Alist of subrs called, in GC testing. -Each entry has the form (FUNCTION . FUNCTIONS-IT-CALLS).") - - -;;; Functions on this list are safe, even if they appear to be able -;;; to call the target. - -(defvar find-gc-noreturn-list '(Fsignal Fthrow wrong_type_argument)) - -;;; This was originally generated directory-files, but there were -;;; too many files there that were not actually compiled. The -;;; list below was created for a HP-UX 7.0 system. - -(defvar find-gc-source-files - '("dispnew.c" "scroll.c" "xdisp.c" "window.c" - "term.c" "cm.c" "emacs.c" "keyboard.c" "macros.c" - "keymap.c" "sysdep.c" "buffer.c" "filelock.c" - "insdel.c" "marker.c" "minibuf.c" "fileio.c" - "dired.c" "cmds.c" "casefiddle.c" - "indent.c" "search.c" "regex.c" "undo.c" - "alloc.c" "data.c" "doc.c" "editfns.c" - "callint.c" "eval.c" "fns.c" "print.c" "lread.c" - "abbrev.c" "syntax.c" "unexcoff.c" - "bytecode.c" "process.c" "callproc.c" "doprnt.c" - "x11term.c" "x11fns.c")) - - -(defun find-gc-unsafe () - "Return a list of unsafe functions--that is, which can call GC. -Also store it in `find-gc-unsafe'." - (trace-call-tree nil) - (trace-use-tree) - (find-unsafe-funcs 'Fgarbage_collect) - (setq find-gc-unsafe-list - (sort find-gc-unsafe-list - (function (lambda (x y) - (string-lessp (car x) (car y)))))) -) - -;;; This does a depth-first search to find all functions that can -;;; ultimately call the function "target". The result is an a-list -;;; in find-gc-unsafe-list; the cars are the unsafe functions, and the cdrs -;;; are (one of) the unsafe functions that these functions directly -;;; call. - -(defun find-unsafe-funcs (target) - (setq find-gc-unsafe-list (list (list target))) - (trace-unsafe target) -) - -(defun trace-unsafe (func) - (let ((used (assq func find-gc-subrs-callers))) - (or used - (error "No find-gc-subrs-callers for %s" (car find-gc-unsafe-list))) - (while (setq used (cdr used)) - (or (assq (car used) find-gc-unsafe-list) - (memq (car used) find-gc-noreturn-list) - (progn - (push (cons (car used) func) find-gc-unsafe-list) - (trace-unsafe (car used)))))) -) - - - - -(defun trace-call-tree (&optional already-setup) - (message "Setting up directories...") - (or already-setup - (progn - ;; Gee, wouldn't a built-in "system" function be handy here. - (call-process "csh" nil nil nil "-c" "rm -rf /tmp/esrc") - (call-process "csh" nil nil nil "-c" "mkdir /tmp/esrc") - (call-process "csh" nil nil nil "-c" - (format "ln -s %s/*.[ch] /tmp/esrc" - find-gc-source-directory)))) - (with-current-buffer (get-buffer-create "*Trace Call Tree*") - (setq find-gc-subrs-called nil) - (let ((case-fold-search nil) - (files find-gc-source-files) - name entry) - (while files - (message "Compiling %s..." (car files)) - (call-process "csh" nil nil nil "-c" - (format "gcc -dr -c /tmp/esrc/%s -o /dev/null" - (car files))) - (erase-buffer) - (insert-file-contents (concat "/tmp/esrc/" (car files) ".rtl")) - (while (re-search-forward ";; Function \\|(call_insn " nil t) - (if (= (char-after (- (point) 3)) ?o) - (progn - (looking-at "[a-zA-Z0-9_]+") - (setq name (intern (buffer-substring (match-beginning 0) - (match-end 0)))) - (message "%s : %s" (car files) name) - (setq entry (list name) - find-gc-subrs-called (cons entry find-gc-subrs-called))) - (if (looking-at ".*\n?.*\"\\([A-Za-z0-9_]+\\)\"") - (progn - (setq name (intern (buffer-substring (match-beginning 1) - (match-end 1)))) - (or (memq name (cdr entry)) - (setcdr entry (cons name (cdr entry)))))))) - (delete-file (concat "/tmp/esrc/" (car files) ".rtl")) - (setq files (cdr files))))) -) - - -(defun trace-use-tree () - (setq find-gc-subrs-callers (mapcar 'list (mapcar 'car find-gc-subrs-called))) - (let ((ptr find-gc-subrs-called) - p2 found) - (while ptr - (setq p2 (car ptr)) - (while (setq p2 (cdr p2)) - (if (setq found (assq (car p2) find-gc-subrs-callers)) - (setcdr found (cons (car (car ptr)) (cdr found))))) - (setq ptr (cdr ptr)))) -) - -(provide 'find-gc) - -;;; find-gc.el ends here diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index 6dee2cb48da..0320662af94 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-2015 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal ;; Package: emacs diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el new file mode 100644 index 00000000000..123f64b9660 --- /dev/null +++ b/lisp/emacs-lisp/generator.el @@ -0,0 +1,796 @@ +;;; generator.el --- generators -*- lexical-binding: t -*- + +;;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Daniel Colascione <dancol@dancol.org> +;; Keywords: extensions, elisp +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package implements generators for Emacs Lisp through a +;; continuation-passing transformation. It provides essentially the +;; same generator API and iterator facilities that Python and +;; JavaScript ES6 provide. +;; +;; `iter-lambda' and `iter-defun' work like `lambda' and `defun', +;; except that they evaluate to or define, respectively, generator +;; functions. These functions, when called, return an iterator. +;; An iterator is an opaque object that generates a sequence of +;; values. Callers use `iter-next' to retrieve the next value from +;; the sequence; when the sequence is exhausted, `iter-next' will +;; raise the `iter-end-of-sequence' condition. +;; +;; Generator functions are written like normal functions, except that +;; they can invoke `iter-yield' to suspend themselves and return a +;; value to callers; this value becomes the return value of +;; `iter-next'. On the next call to `iter-next', execution of the +;; generator function resumes where it left off. When a generator +;; function returns normally, the `iter-next' raises +;; `iter-end-of-sequence' with the value the function returned. +;; +;; `iter-yield-from' yields all the values from another iterator; it +;; then evaluates to the value the sub-iterator returned normally. +;; This facility is useful for functional composition of generators +;; and for implementing coroutines. +;; +;; `iter-yield' is illegal inside the UNWINDFORMS of an +;; `unwind-protect' for various sordid internal reasons documented in +;; the code. +;; +;; N.B. Each call to a generator function generates a *new* iterator, +;; and each iterator maintains its own internal state. +;; +;; This raw form of iteration is general, but a bit awkward to use, so +;; this library also provides some convenience functions: +;; +;; `iter-do' is like `cl-do', except that instead of walking a list, +;; it walks an iterator. `cl-loop' is also extended with a new +;; keyword, `iter-by', that iterates over an iterator. +;; + +;;; Implementation: + +;; +;; The internal cps transformation code uses the cps- namespace. +;; Iteration functions use the `iter-' namespace. Generator functions +;; are somewhat less efficient than conventional elisp routines, +;; although we try to avoid CPS transformation on forms that do not +;; invoke `iter-yield'. +;; + +;;; Code: + +(require 'cl-lib) +(require 'pcase) + +(defvar cps--bindings nil) +(defvar cps--states nil) +(defvar cps--value-symbol nil) +(defvar cps--state-symbol nil) +(defvar cps--cleanup-table-symbol nil) +(defvar cps--cleanup-function nil) + +(defmacro cps--gensym (fmt &rest args) + ;; Change this function to use `cl-gensym' if you want the generated + ;; code to be easier to read and debug. + ;; (cl-gensym (apply #'format fmt args)) + `(progn (ignore ,@args) (make-symbol ,fmt))) + +(defvar cps--dynamic-wrappers '(identity) + "List of transformer functions to apply to atomic forms we +evaluate in CPS context.") + +(defconst cps-standard-special-forms + '(setq setq-default throw interactive) + "List of special forms that we treat just like ordinary + function applications." ) + +(defun cps--trace-funcall (func &rest args) + (message "%S: args=%S" func args) + (let ((result (apply func args))) + (message "%S: result=%S" func result) + result)) + +(defun cps--trace (fmt &rest args) + (princ (apply #'format (concat fmt "\n") args))) + +(defun cps--special-form-p (definition) + "Non-nil if and only if DEFINITION is a special form." + ;; Copied from ad-special-form-p + (if (and (symbolp definition) (fboundp definition)) + (setf definition (indirect-function definition))) + (and (subrp definition) (eq (cdr (subr-arity definition)) 'unevalled))) + +(defmacro cps--define-unsupported (function) + `(defun ,(intern (format "cps--transform-%s" function)) + (error "%s not supported in generators" ,function))) + +(defmacro cps--with-value-wrapper (wrapper &rest body) + "Continue generating CPS code with an atomic-form wrapper +to the current stack of such wrappers. WRAPPER is a function that +takes a form and returns a wrapped form. + +Whenever we generate an atomic form (i.e., a form that can't +iter-yield), we first (before actually inserting that form in our +generated code) pass that form through all the transformer +functions. We use this facility to wrap forms that can transfer +control flow non-locally in goo that diverts this control flow to +the CPS state machinery. +" + (declare (indent 1)) + `(let ((cps--dynamic-wrappers + (cons + ,wrapper + cps--dynamic-wrappers))) + ,@body)) + +(defun cps--make-dynamic-binding-wrapper (dynamic-var static-var) + (cl-assert lexical-binding) + (lambda (form) + `(let ((,dynamic-var ,static-var)) + (unwind-protect ; Update the static shadow after evaluation is done + ,form + (setf ,static-var ,dynamic-var)) + ,form))) + +(defmacro cps--with-dynamic-binding (dynamic-var static-var &rest body) + "Evaluate BODY such that generated atomic evaluations run with +DYNAMIC-VAR bound to STATIC-VAR." + (declare (indent 2)) + `(cps--with-value-wrapper + (cps--make-dynamic-binding-wrapper ,dynamic-var ,static-var) + ,@body)) + +(defun cps--add-state (kind body) + "Create a new CPS state with body BODY and return the state's name." + (declare (indent 1)) + (let* ((state (cps--gensym "cps-state-%s-" kind))) + (push (list state body cps--cleanup-function) cps--states) + (push state cps--bindings) + state)) + +(defun cps--add-binding (original-name) + (car (push (cps--gensym (format "cps-binding-%s-" original-name)) + cps--bindings))) + +(defun cps--find-special-form-handler (form) + (let* ((handler-name (format "cps--transform-%s" (car-safe form))) + (handler (intern-soft handler-name))) + (and (fboundp handler) handler))) + +(defvar cps-inhibit-atomic-optimization nil + "When t, always rewrite forms into cps even when they +don't yield.") + +(defvar cps--yield-seen) + +(defun cps--atomic-p (form) + "Return whether the given form never yields." + + (and (not cps-inhibit-atomic-optimization) + (let* ((cps--yield-seen)) + (ignore (macroexpand-all + `(cl-macrolet ((cps-internal-yield + (_val) + (setf cps--yield-seen t))) + ,form) + macroexpand-all-environment)) + (not cps--yield-seen)))) + +(defun cps--make-atomic-state (form next-state) + (let ((tform `(prog1 ,form (setf ,cps--state-symbol ,next-state)))) + (cl-loop for wrapper in cps--dynamic-wrappers + do (setf tform (funcall wrapper tform))) + ;; Bind cps--cleanup-function to nil here because the wrapper + ;; function mechanism is responsible for cleanup here, not the + ;; generic cleanup mechanism. If we didn't make this binding, + ;; we'd run cleanup handlers twice on anything that made it out + ;; to toplevel. + (let ((cps--cleanup-function nil)) + (cps--add-state "atom" + `(setf ,cps--value-symbol ,tform))))) + +(defun cps--transform-1 (form next-state) + (pcase form + + ;; If we're looking at an "atomic" form (i.e., one that does not + ;; iter-yield), just evaluate the form as a whole instead of rewriting + ;; it into CPS. + + ((guard (cps--atomic-p form)) + (cps--make-atomic-state form next-state)) + + ;; Process `and'. + + (`(and) ; (and) -> t + (cps--transform-1 t next-state)) + (`(and ,condition) ; (and CONDITION) -> CONDITION + (cps--transform-1 condition next-state)) + (`(and ,condition . ,rest) + ;; Evaluate CONDITION; if it's true, go on to evaluate the rest + ;; of the `and'. + (cps--transform-1 + condition + (cps--add-state "and" + `(setf ,cps--state-symbol + (if ,cps--value-symbol + ,(cps--transform-1 `(and ,@rest) + next-state) + ,next-state))))) + + ;; Process `catch'. + + (`(catch ,tag . ,body) + (let ((tag-binding (cps--add-binding "catch-tag"))) + (cps--transform-1 tag + (cps--add-state "cps-update-tag" + `(setf ,tag-binding ,cps--value-symbol + ,cps--state-symbol + ,(cps--with-value-wrapper + (cps--make-catch-wrapper + tag-binding next-state) + (cps--transform-1 `(progn ,@body) + next-state))))))) + + ;; Process `cond': transform into `if' or `or' depending on the + ;; precise kind of the condition we're looking at. + + (`(cond) ; (cond) -> nil + (cps--transform-1 nil next-state)) + (`(cond (,condition) . ,rest) + (cps--transform-1 `(or ,condition (cond ,@rest)) + next-state)) + (`(cond (,condition . ,body) . ,rest) + (cps--transform-1 `(if ,condition + (progn ,@body) + (cond ,@rest)) + next-state)) + + ;; Process `condition-case': do the heavy lifting in a helper + ;; function. + + (`(condition-case ,var ,bodyform . ,handlers) + (cps--with-value-wrapper + (cps--make-condition-wrapper var next-state handlers) + (cps--transform-1 bodyform + next-state))) + + ;; Process `if'. + + (`(if ,cond ,then . ,else) + (cps--transform-1 cond + (cps--add-state "if" + `(setf ,cps--state-symbol + (if ,cps--value-symbol + ,(cps--transform-1 then + next-state) + ,(cps--transform-1 `(progn ,@else) + next-state)))))) + + ;; Process `progn' and `inline': they are identical except for the + ;; name, which has some significance to the byte compiler. + + (`(inline) (cps--transform-1 nil next-state)) + (`(inline ,form) (cps--transform-1 form next-state)) + (`(inline ,form . ,rest) + (cps--transform-1 form + (cps--transform-1 `(inline ,@rest) + next-state))) + + (`(progn) (cps--transform-1 nil next-state)) + (`(progn ,form) (cps--transform-1 form next-state)) + (`(progn ,form . ,rest) + (cps--transform-1 form + (cps--transform-1 `(progn ,@rest) + next-state))) + + ;; Process `let' in a helper function that transforms it into a + ;; let* with temporaries. + + (`(let ,bindings . ,body) + (let* ((bindings (cl-loop for binding in bindings + collect (if (symbolp binding) + (list binding nil) + binding))) + (temps (cl-loop for (var _value-form) in bindings + collect (cps--add-binding var)))) + (cps--transform-1 + `(let* ,(append + (cl-loop for (_var value-form) in bindings + for temp in temps + collect (list temp value-form)) + (cl-loop for (var _binding) in bindings + for temp in temps + collect (list var temp))) + ,@body) + next-state))) + + ;; Process `let*' binding: process one binding at a time. Flatten + ;; lexical bindings. + + (`(let* () . ,body) + (cps--transform-1 `(progn ,@body) next-state)) + + (`(let* (,binding . ,more-bindings) . ,body) + (let* ((var (if (symbolp binding) binding (car binding))) + (value-form (car (cdr-safe binding))) + (new-var (cps--add-binding var))) + + (cps--transform-1 + value-form + (cps--add-state "let*" + `(setf ,new-var ,cps--value-symbol + ,cps--state-symbol + ,(if (or (not lexical-binding) (special-variable-p var)) + (cps--with-dynamic-binding var new-var + (cps--transform-1 + `(let* ,more-bindings ,@body) + next-state)) + (cps--transform-1 + (cps--replace-variable-references + var new-var + `(let* ,more-bindings ,@body)) + next-state))))))) + + ;; Process `or'. + + (`(or) (cps--transform-1 nil next-state)) + (`(or ,condition) (cps--transform-1 condition next-state)) + (`(or ,condition . ,rest) + (cps--transform-1 + condition + (cps--add-state "or" + `(setf ,cps--state-symbol + (if ,cps--value-symbol + ,next-state + ,(cps--transform-1 + `(or ,@rest) next-state)))))) + + ;; Process `prog1'. + + (`(prog1 ,first) (cps--transform-1 first next-state)) + (`(prog1 ,first . ,body) + (cps--transform-1 + first + (let ((temp-var-symbol (cps--add-binding "prog1-temp"))) + (cps--add-state "prog1" + `(setf ,temp-var-symbol + ,cps--value-symbol + ,cps--state-symbol + ,(cps--transform-1 + `(progn ,@body) + (cps--add-state "prog1inner" + `(setf ,cps--value-symbol ,temp-var-symbol + ,cps--state-symbol ,next-state)))))))) + + ;; Process `prog2'. + + (`(prog2 ,form1 ,form2 . ,body) + (cps--transform-1 + `(progn ,form1 (prog1 ,form2 ,@body)) + next-state)) + + ;; Process `unwind-protect': If we're inside an unwind-protect, we + ;; have a block of code UNWINDFORMS which we would like to run + ;; whenever control flows away from the main piece of code, + ;; BODYFORM. We deal with the local control flow case by + ;; generating BODYFORM such that it yields to a continuation that + ;; executes UNWINDFORMS, which then yields to NEXT-STATE. + ;; + ;; Non-local control flow is trickier: we need to ensure that we + ;; execute UNWINDFORMS even when control bypasses our normal + ;; continuation. To make this guarantee, we wrap every external + ;; application (i.e., every piece of elisp that can transfer + ;; control non-locally) in an unwind-protect that runs UNWINDFORMS + ;; before allowing the non-local control transfer to proceed. + ;; + ;; Unfortunately, because elisp lacks a mechanism for generically + ;; capturing the reason for an arbitrary non-local control + ;; transfer and restarting the transfer at a later point, we + ;; cannot reify non-local transfers and cannot allow + ;; continuation-passing code inside UNWINDFORMS. + + (`(unwind-protect ,bodyform . ,unwindforms) + ;; Signal the evaluator-generator that it needs to generate code + ;; to handle cleanup forms. + (unless cps--cleanup-table-symbol + (setf cps--cleanup-table-symbol (cps--gensym "cps-cleanup-table-"))) + (let* ((unwind-state + (cps--add-state + "unwind" + ;; N.B. It's safe to just substitute unwindforms by + ;; sexp-splicing: we've already replaced all variable + ;; references inside it with lifted equivalents. + `(progn + ,@unwindforms + (setf ,cps--state-symbol ,next-state)))) + (old-cleanup cps--cleanup-function) + (cps--cleanup-function + (let ((cps--cleanup-function nil)) + (cps--add-state "cleanup" + `(progn + ,(when old-cleanup `(funcall ,old-cleanup)) + ,@unwindforms))))) + (cps--with-value-wrapper + (cps--make-unwind-wrapper unwindforms) + (cps--transform-1 bodyform unwind-state)))) + + ;; Process `while'. + + (`(while ,test . ,body) + ;; Open-code state addition instead of using cps--add-state: we + ;; need our states to be self-referential. (That's what makes the + ;; state a loop.) + (let* ((loop-state + (cps--gensym "cps-state-while-")) + (eval-loop-condition-state + (cps--transform-1 test loop-state)) + (loop-state-body + `(progn + (setf ,cps--state-symbol + (if ,cps--value-symbol + ,(cps--transform-1 + `(progn ,@body) + eval-loop-condition-state) + ,next-state))))) + (push (list loop-state loop-state-body cps--cleanup-function) + cps--states) + (push loop-state cps--bindings) + eval-loop-condition-state)) + + ;; Process various kinds of `quote'. + + (`(quote ,arg) (cps--add-state "quote" + `(setf ,cps--value-symbol (quote ,arg) + ,cps--state-symbol ,next-state))) + (`(function ,arg) (cps--add-state "function" + `(setf ,cps--value-symbol (function ,arg) + ,cps--state-symbol ,next-state))) + + ;; Deal with `iter-yield'. + + (`(cps-internal-yield ,value) + (cps--transform-1 + value + (cps--add-state "iter-yield" + `(progn + (setf ,cps--state-symbol + ,(if cps--cleanup-function + (cps--add-state "after-yield" + `(setf ,cps--state-symbol ,next-state)) + next-state)) + (throw 'cps--yield ,cps--value-symbol))))) + + ;; Catch any unhandled special forms. + + ((and `(,name . ,_) + (guard (cps--special-form-p name)) + (guard (not (memq name cps-standard-special-forms)))) + name ; Shut up byte compiler + (error "special form %S incorrect or not supported" form)) + + ;; Process regular function applications with nontrivial + ;; parameters, converting them to applications of trivial + ;; let-bound parameters. + + ((and `(,function . ,arguments) + (guard (not (cl-loop for argument in arguments + always (atom argument))))) + (let ((argument-symbols + (cl-loop for argument in arguments + collect (if (atom argument) + argument + (cps--gensym "cps-argument-"))))) + + (cps--transform-1 + `(let* ,(cl-loop for argument in arguments + for argument-symbol in argument-symbols + unless (eq argument argument-symbol) + collect (list argument-symbol argument)) + ,(cons function argument-symbols)) + next-state))) + + ;; Process everything else by just evaluating the form normally. + (_ (cps--make-atomic-state form next-state)))) + +(defun cps--make-catch-wrapper (tag-binding next-state) + (lambda (form) + (let ((normal-exit-symbol + (cps--gensym "cps-normal-exit-from-catch-"))) + `(let (,normal-exit-symbol) + (prog1 + (catch ,tag-binding + (prog1 + ,form + (setf ,normal-exit-symbol t))) + (unless ,normal-exit-symbol + (setf ,cps--state-symbol ,next-state))))))) + +(defun cps--make-condition-wrapper (var next-state handlers) + ;; Each handler is both one of the transformers with which we wrap + ;; evaluated atomic forms and a state to which we jump when we + ;; encounter the given error. + + (let* ((error-symbol (cps--add-binding "condition-case-error")) + (lexical-error-symbol (cps--gensym "cps-lexical-error-")) + (processed-handlers + (cl-loop for (condition . body) in handlers + collect (cons condition + (cps--transform-1 + (cps--replace-variable-references + var error-symbol + `(progn ,@body)) + next-state))))) + + (lambda (form) + `(condition-case + ,lexical-error-symbol + ,form + ,@(cl-loop + for (condition . error-state) in processed-handlers + collect + `(,condition + (setf ,error-symbol + ,lexical-error-symbol + ,cps--state-symbol + ,error-state))))))) + +(defun cps--replace-variable-references (var new-var form) + "Replace all non-shadowed references to VAR with NEW-VAR in FORM. +This routine does not modify FORM. Instead, it returns a +modified copy." + (macroexpand-all + `(cl-symbol-macrolet ((,var ,new-var)) ,form) + macroexpand-all-environment)) + +(defun cps--make-unwind-wrapper (unwind-forms) + (cl-assert lexical-binding) + (lambda (form) + (let ((normal-exit-symbol + (cps--gensym "cps-normal-exit-from-unwind-"))) + `(let (,normal-exit-symbol) + (unwind-protect + (prog1 + ,form + (setf ,normal-exit-symbol t)) + (unless ,normal-exit-symbol + ,@unwind-forms)))))) + +(put 'iter-end-of-sequence 'error-conditions '(iter-end-of-sequence)) +(put 'iter-end-of-sequence 'error-message "iteration terminated") + +(defun cps--make-close-iterator-form (terminal-state) + (if cps--cleanup-table-symbol + `(let ((cleanup (cdr (assq ,cps--state-symbol ,cps--cleanup-table-symbol)))) + (setf ,cps--state-symbol ,terminal-state + ,cps--value-symbol nil) + (when cleanup (funcall cleanup))) + `(setf ,cps--state-symbol ,terminal-state + ,cps--value-symbol nil))) + +(defun cps-generate-evaluator (body) + (let* (cps--states + cps--bindings + cps--cleanup-function + (cps--value-symbol (cps--gensym "cps-current-value-")) + (cps--state-symbol (cps--gensym "cps-current-state-")) + ;; We make *cps-cleanup-table-symbol** non-nil when we notice + ;; that we have cleanup processing to perform. + (cps--cleanup-table-symbol nil) + (terminal-state (cps--add-state "terminal" + `(signal 'iter-end-of-sequence + ,cps--value-symbol))) + (initial-state (cps--transform-1 + (macroexpand-all + `(cl-macrolet + ((iter-yield (value) + `(cps-internal-yield ,value))) + ,@body) + macroexpand-all-environment) + terminal-state)) + (finalizer-symbol + (when cps--cleanup-table-symbol + (when cps--cleanup-table-symbol + (cps--gensym "cps-iterator-finalizer-"))))) + `(let ,(append (list cps--state-symbol cps--value-symbol) + (when cps--cleanup-table-symbol + (list cps--cleanup-table-symbol)) + (when finalizer-symbol + (list finalizer-symbol)) + (nreverse cps--bindings)) + ;; Order state list so that cleanup states are always defined + ;; before they're referenced. + ,@(cl-loop for (state body cleanup) in (nreverse cps--states) + collect `(setf ,state (lambda () ,body)) + when cleanup + do (cl-assert cps--cleanup-table-symbol) + and collect `(push (cons ,state ,cleanup) ,cps--cleanup-table-symbol)) + (setf ,cps--state-symbol ,initial-state) + + (let ((iterator + (lambda (op value) + (cond + ,@(when finalizer-symbol + `(((eq op :stash-finalizer) + (setf ,finalizer-symbol value)) + ((eq op :get-finalizer) + ,finalizer-symbol))) + ((eq op :close) + ,(cps--make-close-iterator-form terminal-state)) + ((eq op :next) + (setf ,cps--value-symbol value) + (let ((yielded nil)) + (unwind-protect + (prog1 + (catch 'cps--yield + (while t + (funcall ,cps--state-symbol))) + (setf yielded t)) + (unless yielded + ;; If we're exiting non-locally (error, quit, + ;; etc.) close the iterator. + ,(cps--make-close-iterator-form terminal-state))))) + (t (error "unknown iterator operation %S" op)))))) + ,(when finalizer-symbol + `(funcall iterator + :stash-finalizer + (make-finalizer + (lambda () + (iter-close iterator))))) + iterator)))) + +(defun iter-yield (value) + "When used inside a generator, yield control to caller. +The caller of `iter-next' receives VALUE, and the next call to +`iter-next' resumes execution at the previous +`iter-yield' point." + (identity value) + (error "`iter-yield' used outside a generator")) + +(defmacro iter-yield-from (value) + "When used inside a generator function, delegate to a sub-iterator. +The values that the sub-iterator yields are passed directly to +the caller, and values supplied to `iter-next' are sent to the +sub-iterator. `iter-yield-from' evaluates to the value that the +sub-iterator function returns via `iter-end-of-sequence'." + (let ((errsym (cps--gensym "yield-from-result")) + (valsym (cps--gensym "yield-from-value"))) + `(let ((,valsym ,value)) + (unwind-protect + (condition-case ,errsym + (let ((vs nil)) + (while t + (setf vs (iter-yield (iter-next ,valsym vs))))) + (iter-end-of-sequence (cdr ,errsym))) + (iter-close ,valsym))))) + +(defmacro iter-defun (name arglist &rest body) + "Creates a generator NAME. +When called as a function, NAME returns an iterator value that +encapsulates the state of a computation that produces a sequence +of values. Callers can retrieve each value using `iter-next'." + (declare (indent defun)) + (cl-assert lexical-binding) + (let* ((parsed-body (macroexp-parse-body body)) + (declarations (car parsed-body)) + (exps (cdr parsed-body))) + `(defun ,name ,arglist + ,@declarations + ,(cps-generate-evaluator exps)))) + +(defmacro iter-lambda (arglist &rest body) + "Return a lambda generator. +`iter-lambda' is to `iter-defun' as `lambda' is to `defun'." + (declare (indent defun)) + (cl-assert lexical-binding) + `(lambda ,arglist + ,(cps-generate-evaluator body))) + +(defun iter-next (iterator &optional yield-result) + "Extract a value from an iterator. +YIELD-RESULT becomes the return value of `iter-yield' in the +context of the generator. + +This routine raises the `iter-end-of-sequence' condition if the +iterator cannot supply more values." + (funcall iterator :next yield-result)) + +(defun iter-close (iterator) + "Terminate an iterator early. +Run any unwind-protect handlers in scope at the point ITERATOR +is blocked." + (funcall iterator :close nil)) + +(cl-defmacro iter-do ((var iterator) &rest body) + "Loop over values from an iterator. +Evaluate BODY with VAR bound to each value from ITERATOR. +Return the value with which ITERATOR finished iteration." + (declare (indent 1)) + (let ((done-symbol (cps--gensym "iter-do-iterator-done")) + (condition-symbol (cps--gensym "iter-do-condition")) + (it-symbol (cps--gensym "iter-do-iterator")) + (result-symbol (cps--gensym "iter-do-result"))) + `(let (,var + ,result-symbol + (,done-symbol nil) + (,it-symbol ,iterator)) + (while (not ,done-symbol) + (condition-case ,condition-symbol + (setf ,var (iter-next ,it-symbol)) + (iter-end-of-sequence + (setf ,result-symbol (cdr ,condition-symbol)) + (setf ,done-symbol t))) + (unless ,done-symbol ,@body)) + ,result-symbol))) + +(defvar cl--loop-args) + +(defmacro cps--advance-for (conscell) + ;; See cps--handle-loop-for + `(condition-case nil + (progn + (setcar ,conscell (iter-next (cdr ,conscell))) + ,conscell) + (iter-end-of-sequence + nil))) + +(defmacro cps--initialize-for (iterator) + ;; See cps--handle-loop-for + (let ((cs (cps--gensym "cps--loop-temp"))) + `(let ((,cs (cons nil ,iterator))) + (cps--advance-for ,cs)))) + +(defun cps--handle-loop-for (var) + "Support `iter-by' in `loop'. " + ;; N.B. While the cl-loop-for-handler is a documented interface, + ;; there's no documented way for cl-loop-for-handler callbacks to do + ;; anything useful! Additionally, cl-loop currently lexbinds useful + ;; internal variables, so our only option is to modify + ;; cl--loop-args. If we substitute a general-purpose for-clause for + ;; our iterating clause, however, we can't preserve the + ;; parallel-versus-sequential `loop' semantics for for clauses --- + ;; we need a terminating condition as well, which requires us to use + ;; while, and inserting a while would break and-sequencing. + ;; + ;; To work around this problem, we actually use the "for var in LIST + ;; by FUNCTION" syntax, creating a new fake list each time through + ;; the loop, this "list" being a cons cell (val . it). + (let ((it-form (pop cl--loop-args))) + (setf cl--loop-args + (append + `(for ,var + in (cps--initialize-for ,it-form) + by 'cps--advance-for) + cl--loop-args)))) + +(put 'iter-by 'cl-loop-for-handler 'cps--handle-loop-for) + +(eval-after-load 'elisp-mode + (lambda () + (font-lock-add-keywords + 'emacs-lisp-mode + '(("(\\(iter-defun\\)\\_>\\s *\\(\\(?:\\sw\\|\\s_\\)+\\)?" + (1 font-lock-keyword-face nil t) + (2 font-lock-function-name-face nil t)) + ("(\\(iter-\\(?:next\\|lambda\\|yield\\|yield-from\\)\\)\\_>" + (1 font-lock-keyword-face nil t)))))) + +(provide 'generator) + +;;; generator.el ends here diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index 3eb64f9f7f0..b7f4070cf60 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-2015 Free Software Foundation, Inc. ;; ;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Fri Sep 27 1996 @@ -224,7 +224,7 @@ Some generic modes are defined in `generic-x.el'." ;;; Comment Functionality -(defun generic--normalise-comments (comment-list) +(defun generic--normalize-comments (comment-list) (let ((normalized '())) (dolist (start comment-list) (let (end) @@ -300,7 +300,7 @@ Some generic modes are defined in `generic-x.el'." (defun generic-mode-set-comments (comment-list) "Set up comment functionality for generic mode." (let ((st (make-syntax-table)) - (comment-list (generic--normalise-comments comment-list))) + (comment-list (generic--normalize-comments comment-list))) (generic-set-comment-syntax st comment-list) (generic-set-comment-vars comment-list) (set-syntax-table st))) diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el deleted file mode 100644 index d3a43329366..00000000000 --- a/lisp/emacs-lisp/gulp.el +++ /dev/null @@ -1,177 +0,0 @@ -;;; gulp.el --- ask for updates for Lisp packages - -;; Copyright (C) 1996, 2001-2013 Free Software Foundation, Inc. - -;; Author: Sam Shteingold <shteingd@math.ucla.edu> -;; Maintainer: FSF -;; Keywords: maint - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 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: - -;; Search the emacs/{version}/lisp directory for *.el files, extract the -;; name of the author or maintainer and send him e-mail requesting -;; update. - -;;; Code: -(defgroup gulp nil - "Ask for updates for Lisp packages." - :prefix "-" - :group 'maint) - -(defcustom gulp-discard "^;+ *Maintainer: *FSF *$" - "The regexp matching the packages not requiring the request for updates." - :type 'regexp - :group 'gulp) - -(defcustom gulp-tmp-buffer "*gulp*" - "The name of the temporary buffer." - :type 'string - :group 'gulp) - -(defcustom gulp-max-len 2000 - "Distance into a Lisp source file to scan for keywords." - :type 'integer - :group 'gulp) - -(defcustom gulp-request-header - (concat - "This message was created automatically. -I'm going to start pretesting a new version of GNU Emacs soon, so I'd -like to ask if you have any updates for the Emacs packages you work on. -You're listed as the maintainer of the following package(s):\n\n") - "The starting text of a gulp message." - :type 'string - :group 'gulp) - -(defcustom gulp-request-end - (concat - "\nIf you have any changes since the version in the previous release (" - (format "%d.%d" emacs-major-version emacs-minor-version) - "), -please send them to me ASAP. - -Please don't send the whole file. Instead, please send a patch made with -`diff -c' that shows precisely the changes you would like me to install. -Also please include itemized change log entries for your changes; -please use lisp/ChangeLog as a guide for the style and for what kinds -of information to include. - -Thanks.") - "The closing text in a gulp message." - :type 'string - :group 'gulp) - -(declare-function mail-subject "sendmail" ()) -(declare-function mail-send "sendmail" ()) - -(defun gulp-send-requests (dir &optional time) - "Send requests for updates to the authors of Lisp packages in directory DIR. -For each maintainer, the message consists of `gulp-request-header', -followed by the list of packages (with modification times if the optional -prefix argument TIME is non-nil), concluded with `gulp-request-end'. - -You can't edit the messages, but you can confirm whether to send each one. - -The list of addresses for which you decided not to send mail -is left in the `*gulp*' buffer at the end." - (interactive "DRequest updates for Lisp directory: \nP") - (with-current-buffer (get-buffer-create gulp-tmp-buffer) - (let ((m-p-alist (gulp-create-m-p-alist - (directory-files dir nil "^[^=].*\\.el$" t) - dir)) - ;; Temporarily inhibit undo in the *gulp* buffer. - (buffer-undo-list t) - mail-setup-hook msg node) - (setq m-p-alist - (sort m-p-alist - (function (lambda (a b) - (string< (car a) (car b)))))) - (while (setq node (car m-p-alist)) - (setq msg (gulp-create-message (cdr node) time)) - (setq mail-setup-hook - (lambda () - (mail-subject) - (insert "It's time for Emacs updates again") - (goto-char (point-max)) - (insert msg))) - (mail nil (car node)) - (goto-char (point-min)) - (if (y-or-n-p "Send? ") (mail-send) - (kill-this-buffer) - (set-buffer gulp-tmp-buffer) - (insert (format "%s\n\n" node))) - (setq m-p-alist (cdr m-p-alist)))) - (set-buffer gulp-tmp-buffer) - (setq buffer-undo-list nil))) - - -(defun gulp-create-message (rec time) - "Return the message string for REC, which is a list like (FILE TIME)." - (let (node (str gulp-request-header)) - (while (setq node (car rec)) - (setq str (concat str "\t" (car node) - (if time (concat "\tLast modified:\t" (cdr node))) - "\n")) - (setq rec (cdr rec))) - (concat str gulp-request-end))) - - -(defun gulp-create-m-p-alist (flist dir) - "Create the maintainer/package alist for files in FLIST in DIR. -That is a list of elements, each of the form (MAINTAINER PACKAGES...)." - (save-excursion - (let (mplist filen node mnt-tm mnt tm fl-tm) - (get-buffer-create gulp-tmp-buffer) - (set-buffer gulp-tmp-buffer) - (setq buffer-undo-list t) - (while flist - (setq fl-tm (gulp-maintainer (setq filen (car flist)) dir)) - (if (setq tm (cdr fl-tm) mnt (car fl-tm));; there is a definite maintainer - (if (setq node (assoc mnt mplist));; this is not a new maintainer - (setq mplist (cons (cons mnt (cons (cons filen tm) (cdr node))) - (delete node mplist))) - (setq mplist (cons (list mnt (cons filen (cdr fl-tm))) mplist)))) - (setq flist (cdr flist))) - (erase-buffer) - mplist))) - -(defun gulp-maintainer (filenm dir) - "Return a list (MAINTAINER TIMESTAMP) for the package FILENM in directory DIR." - (save-excursion - (let* ((fl (expand-file-name filenm dir)) mnt - (timest (format-time-string "%Y-%m-%d %a %T %Z" - (elt (file-attributes fl) 5)))) - (set-buffer gulp-tmp-buffer) - (erase-buffer) - (insert-file-contents fl nil 0 gulp-max-len) - (goto-char 1) - (if (re-search-forward gulp-discard nil t) - (setq mnt nil) ;; do nothing, return nil - (goto-char 1) - (if (and (re-search-forward "^;+ *Maintainer: \\(.*\\)$" nil t) - (> (length (setq mnt (match-string 1))) 0)) - () ;; found! - (goto-char 1) - (if (re-search-forward "^;+ *Author: \\(.*\\)$" nil t) - (setq mnt (match-string 1)))) - (if (= (length mnt) 0) (setq mnt nil))) ;; "^;; Author: $" --> nil - (cons mnt timest)))) - -(provide 'gulp) - -;;; gulp.el ends here diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 279ae582a05..94fe6c3d441 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-2015 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions @@ -74,6 +74,8 @@ ;; (defvar gv--macro-environment nil ;; "Macro expanders for generalized variables.") +(define-error 'gv-invalid-place "%S is not a valid place expression") + ;;;###autoload (defun gv-get (place do) "Build the code that applies DO to PLACE. @@ -84,15 +86,17 @@ and SETTER is a function which returns the code to set PLACE when called with a (not necessarily copyable) Elisp expression that returns the value to set it to. DO must return an Elisp expression." - (if (symbolp place) - (funcall do place (lambda (v) `(setq ,place ,v))) + (cond + ((symbolp place) (funcall do place (lambda (v) `(setq ,place ,v)))) + ((not (consp place)) (signal 'gv-invalid-place (list place))) + (t (let* ((head (car place)) (gf (function-get head 'gv-expander 'autoload))) (if gf (apply gf do (cdr place)) - (let ((me (macroexpand place ;FIXME: expand one step at a time! - ;; (append macroexpand-all-environment - ;; gv--macro-environment) - macroexpand-all-environment))) + (let ((me (macroexpand-1 place + ;; (append macroexpand-all-environment + ;; gv--macro-environment) + macroexpand-all-environment))) (if (and (eq me place) (get head 'compiler-macro)) ;; Expand compiler macros: this takes care of all the accessors ;; defined via cl-defsubst, such as cXXXr and defstruct slots. @@ -102,8 +106,21 @@ 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) - (gv-get me do))))))) + (if (and (symbolp head) (get head 'setf-method)) + (error "Incompatible place needs recompilation: %S" head) + (let* ((setter (gv-setter head))) + (gv--defsetter head (lambda (&rest args) `(,setter ,@args)) + do (cdr place)))) + (gv-get me do)))))))) + +(defun gv-setter (name) + ;; The name taken from Scheme's SRFI-17. Actually, for SRFI-17, the argument + ;; could/should be a function value rather than a symbol. + "Return the symbol where the (setf NAME) function should be placed." + (if (get name 'gv-expander) + (error "gv-expander conflicts with (setf %S)" name)) + ;; FIXME: This is wrong if `name' is uninterned (or interned elsewhere). + (intern (format "(setf %s)" name))) ;;;###autoload (defmacro gv-letplace (vars place &rest body) @@ -155,11 +172,15 @@ 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) + (let ((x `(gv-expander + ,(apply-partially #'gv--defun-declaration 'gv-expander)))) + (push x macro-declarations-alist) + (push x 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. @@ -197,7 +218,7 @@ return a Lisp form that does the assignment. The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: - (gv-define-setter aref (v a i) `(aset ,a ,i ,v))" + (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))" (declare (indent 2) (debug (&define name sexp body))) `(gv-define-expander ,name (lambda (do &rest args) @@ -212,7 +233,7 @@ turned into calls of the form (SETTER ARGS... VAL). If FIX-RETURN is non-nil, then SETTER is not assumed to return VAL and instead the assignment is turned into something equivalent to - \(let ((temp VAL)) + (let ((temp VAL)) (SETTER ARGS... temp) temp) so as to preserve the semantics of `setf'." @@ -278,9 +299,9 @@ The return value is the last VAL in the list. ;; containing a non-trivial `push' even before gv.el was loaded. ;;;###autoload (put 'gv-place 'edebug-form-spec 'edebug-match-form) + ;; CL did the equivalent of: ;;(gv-define-macroexpand edebug-after (lambda (before index place) place)) - (put 'edebug-after 'gv-expander (lambda (do before index place) (gv-letplace (getter setter) place @@ -336,13 +357,50 @@ The return value is the last VAL in the list. (gv-define-simple-setter process-filter set-process-filter) (gv-define-simple-setter process-sentinel set-process-sentinel) (gv-define-simple-setter process-get process-put) -(gv-define-simple-setter window-buffer set-window-buffer) -(gv-define-simple-setter window-display-table set-window-display-table 'fix) -(gv-define-simple-setter window-dedicated-p set-window-dedicated-p) -(gv-define-simple-setter window-hscroll set-window-hscroll) (gv-define-simple-setter window-parameter set-window-parameter) -(gv-define-simple-setter window-point set-window-point) -(gv-define-simple-setter window-start set-window-start) +(gv-define-setter window-buffer (v &optional w) + (macroexp-let2 nil v v + `(progn (set-window-buffer ,w ,v) ,v))) +(gv-define-setter window-display-table (v &optional w) + (macroexp-let2 nil v v + `(progn (set-window-display-table ,w ,v) ,v))) +(gv-define-setter window-dedicated-p (v &optional w) + `(set-window-dedicated-p ,w ,v)) +(gv-define-setter window-hscroll (v &optional w) `(set-window-hscroll ,w ,v)) +(gv-define-setter window-point (v &optional w) `(set-window-point ,w ,v)) +(gv-define-setter window-start (v &optional w) `(set-window-start ,w ,v)) + +(gv-define-setter buffer-local-value (val var buf) + (macroexp-let2 nil v val + `(with-current-buffer ,buf (set (make-local-variable ,var) ,v)))) + +(gv-define-expander alist-get + (lambda (do key alist &optional default remove) + (macroexp-let2 macroexp-copyable-p k key + (gv-letplace (getter setter) alist + (macroexp-let2 nil p `(assq ,k ,getter) + (funcall do (if (null default) `(cdr ,p) + `(if ,p (cdr ,p) ,default)) + (lambda (v) + (macroexp-let2 nil v v + (let ((set-exp + `(if ,p (setcdr ,p ,v) + ,(funcall setter + `(cons (setq ,p (cons ,k ,v)) + ,getter))))) + (cond + ((null remove) set-exp) + ((or (eql v default) + (and (eq (car-safe v) 'quote) + (eq (car-safe default) 'quote) + (eql (cadr v) (cadr default)))) + `(if ,p ,(funcall setter `(delq ,p ,getter)))) + (t + `(cond + ((not (eql ,default ,v)) ,set-exp) + (,p ,(funcall setter + `(delq ,p ,getter))))))))))))))) + ;;; Some occasionally handy extensions. @@ -419,6 +477,32 @@ The return value is the last VAL in the list. (funcall do `(funcall (car ,gv)) (lambda (v) `(funcall (cdr ,gv) ,v)))))))) +(defmacro gv-synthetic-place (getter setter) + "Special place described by its setter and getter. +GETTER and SETTER (typically obtained via `gv-letplace') get and +set that place. I.e. This macro allows you to do the \"reverse\" of what +`gv-letplace' does. +This macro only makes sense when used in a place." + (declare (gv-expander funcall)) + (ignore setter) + getter) + +(defmacro gv-delay-error (place) + "Special place which delays the `gv-invalid-place' error to run-time. +It behaves just like PLACE except that in case PLACE is not a valid place, +the `gv-invalid-place' error will only be signaled at run-time when (and if) +we try to use the setter. +This macro only makes sense when used in a place." + (declare + (gv-expander + (lambda (do) + (condition-case err + (gv-get place do) + (gv-invalid-place + ;; Delay the error until we try to use the setter. + (funcall do place (lambda (_) `(signal ',(car err) ',(cdr err))))))))) + place) + ;;; Even more debatable extensions. (put 'cons 'gv-expander @@ -448,10 +532,24 @@ 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." - (gv-letplace (getter setter) place - `(cons (lambda () ,getter) - (lambda (gv--val) ,(funcall setter 'gv--val))))) +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." + (let ((code + (gv-letplace (getter setter) place + `(cons (lambda () ,getter) + (lambda (gv--val) ,(funcall setter 'gv--val)))))) + (if (or lexical-binding + ;; If `code' still starts with `cons' then presumably gv-letplace + ;; did not add any new let-bindings, so the `lambda's don't capture + ;; any new variables. As a consequence, the code probably works in + ;; dynamic binding mode as well. + (eq (car-safe code) 'cons)) + code + (macroexp--warn-and-return + "Use of gv-ref probably requires lexical-binding" + code)))) (defsubst gv-deref (ref) "Dereference REF, returning the referenced value. @@ -463,22 +561,13 @@ REF must have been previously obtained with `gv-ref'." ;; … => (load "gv.el") => (macroexpand-all (defsubst gv-deref …)) => (macroexpand (defun …)) => (load "gv.el") (gv-define-setter gv-deref (v ref) `(funcall (cdr ,ref) ,v)) -;;; Vaguely related definitions that should be moved elsewhere. - -;; (defun alist-get (key alist) -;; "Get the value associated to KEY in ALIST." -;; (declare -;; (gv-expander -;; (lambda (do) -;; (macroexp-let2 macroexp-copyable-p k key -;; (gv-letplace (getter setter) alist -;; (macroexp-let2 nil p `(assoc ,k ,getter) -;; (funcall do `(cdr ,p) -;; (lambda (v) -;; `(if ,p (setcdr ,p ,v) -;; ,(funcall setter -;; `(cons (cons ,k ,v) ,getter))))))))))) -;; (cdr (assoc key alist))) +;; (defmacro gv-letref (vars place &rest body) +;; (declare (indent 2) (debug (sexp form &rest body))) +;; (require 'cl-lib) ;Can't require cl-lib at top-level for bootstrap reasons! +;; (gv-letplace (getter setter) place +;; `(cl-macrolet ((,(nth 0 vars) () ',getter) +;; (,(nth 1 vars) (v) (funcall ',setter v))) +;; ,@body))) (provide 'gv) ;;; gv.el ends here diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index 5bef0b06fd4..8b7737b1d3e 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-2015 Free Software Foundation, Inc. ;; Author: K. Shane Hartman -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: help ;; Package: emacs diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el new file mode 100644 index 00000000000..c3f696feda1 --- /dev/null +++ b/lisp/emacs-lisp/inline.el @@ -0,0 +1,262 @@ +;;; inline.el --- Define functions by their inliner -*- lexical-binding:t; -*- + +;; Copyright (C) 2014-2015 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package provides the macro `define-inline' which lets you define +;; functions by defining their (exhaustive) compiler macro. +;; +;; The idea is that instead of doing like defsubst and cl-defsubst (i.e. from +;; the function's definition, guess the best way to inline the function), +;; we go the other way around: the programmer provides the code that does the +;; inlining (as a compiler-macro) and from that we derive the definition of the +;; function itself. The idea originated in an attempt to clean up `cl-typep', +;; whose function definition amounted to (eval (cl--make-type-test EXP TYPE)). +;; +;; The simplest use is for plain and simple inlinable functions. Rather than: +;; +;; (defmacro myaccessor (obj) +;; (macroexp-let2 macroexp-copyable-p obj obj +;; `(if (foop ,obj) (aref (cdr ,obj) 3) (aref ,obj 2)))) +;; Or +;; (defsubst myaccessor (obj) +;; (if (foop obj) (aref (cdr obj) 3) (aref obj 2))) +;; Or +;; (cl-defsubst myaccessor (obj) +;; (if (foop obj) (aref (cdr obj) 3) (aref obj 2))) +;; +;; You'd do +;; +;; (define-inline myaccessor (obj) +;; (inline-letevals (obj) +;; (inline-quote (if (foop ,obj) (aref (cdr ,obj) 3) (aref ,obj 2))))) +;; +;; Other than verbosity, you get the best of all 3 above without their +;; respective downsides: +;; - defmacro: can't be passed to `mapcar' since it's not a function. +;; - defsubst: not as efficient, and doesn't work as a `gv' place. +;; - cl-defsubst: only works by accident, since it has latent bugs in its +;; handling of variables and scopes which could bite you at any time. +;; (e.g. try (cl-defsubst my-test1 (x) (let ((y 5)) (+ x y))) +;; and then M-: (macroexpand-all '(my-test1 y)) RET) +;; There is still one downside shared with the defmacro and cl-defsubst +;; approach: when the function is inlined, the scoping rules (dynamic or +;; lexical) will be inherited from the the call site. + +;; Of course, since define-inline defines a compiler macro, you can also do +;; call-site optimizations, just like you can with `defmacro', but not with +;; defsubst nor cl-defsubst. + +;;; Code: + +(require 'macroexp) + +(defmacro inline-quote (_exp) + "Similar to backquote, but quotes code and only accepts , and not ,@." + (declare (debug t)) + (error "inline-quote can only be used within define-inline")) + +(defmacro inline-const-p (_exp) + "Return non-nil if the value of EXP is already known." + (declare (debug t)) + (error "inline-const-p can only be used within define-inline")) + +(defmacro inline-const-val (_exp) + "Return the value of EXP." + (declare (debug t)) + (error "inline-const-val can only be used within define-inline")) + +(defmacro inline-error (_format &rest _args) + "Signal an error." + (declare (debug t)) + (error "inline-error can only be used within define-inline")) + +(defmacro inline--leteval (_var-exp &rest _body) + (declare (indent 1) (debug (sexp &rest body))) + (error "inline-letevals can only be used within define-inline")) +(defmacro inline--letlisteval (_list &rest _body) + (declare (indent 1) (debug (sexp &rest body))) + (error "inline-letevals can only be used within define-inline")) + +(defmacro inline-letevals (vars &rest body) + "Make sure the expressions in VARS are evaluated. +VARS should be a list of elements of the form (VAR EXP) or just VAR, in case +EXP is equal to VAR. The result is to evaluate EXP and bind the result to VAR. + +The tail of VARS can be either nil or a symbol VAR which should hold a list +of arguments,in which case each argument is evaluated and the resulting +new list is re-bound to VAR. + +After VARS is handled, BODY is evaluated in the new environment." + (declare (indent 1) (debug (sexp &rest form))) + (cond + ((consp vars) + `(inline--leteval ,(pop vars) (inline-letevals ,vars ,@body))) + (vars + `(inline--letlisteval ,vars ,@body)) + (t (macroexp-progn body)))) + +;; (defmacro inline-if (testfun testexp then else) +;; (declare (indent 2) (debug (sexp symbolp form form))) +;; (macroexp-let2 macroexp-copyable-p testsym testexp +;; `(if (inline-const-p ,testexp) +;; (if (,testfun (inline-const-val ,testexp)) ,then ,else) +;; (inline-quote (if (,testfun ,testexp) ,(list '\, then) +;; ,(list '\, else)))))) + +;;;###autoload +(defmacro define-inline (name args &rest body) + ;; FIXME: How can this work with CL arglists? + (declare (indent defun) (debug defun) (doc-string 3)) + (let ((doc (if (stringp (car-safe body)) (list (pop body)))) + (declares (if (eq (car-safe (car-safe body)) 'declare) (pop body))) + (cm-name (intern (format "%s--inliner" name))) + (bodyexp (macroexp-progn body))) + ;; If the function is autoloaded then when we load the .el file, the + ;; `compiler-macro' property is already set (from loaddefs.el) and might + ;; hence be called during the macroexpand-all calls below (if the function + ;; is recursive). + ;; So we disable any pre-loaded compiler-macro setting to avoid this. + (function-put name 'compiler-macro nil) + `(progn + (defun ,name ,args + ,@doc + (declare (compiler-macro ,cm-name) ,@(cdr declares)) + ,(macroexpand-all bodyexp + `((inline-quote . inline--dont-quote) + ;; (inline-\` . inline--dont-quote) + (inline--leteval . inline--dont-leteval) + (inline--letlisteval . inline--dont-letlisteval) + (inline-const-p . inline--alwaysconst-p) + (inline-const-val . inline--alwaysconst-val) + (inline-error . inline--error) + ,@macroexpand-all-environment))) + :autoload-end + (eval-and-compile + (defun ,cm-name ,(cons 'inline--form args) + (ignore inline--form) ;In case it's not used! + (catch 'inline--just-use + ,(macroexpand-all + bodyexp + `((inline-quote . inline--do-quote) + ;; (inline-\` . inline--do-quote) + (inline--leteval . inline--do-leteval) + (inline--letlisteval + . inline--do-letlisteval) + (inline-const-p . inline--testconst-p) + (inline-const-val . inline--getconst-val) + (inline-error . inline--warning) + ,@macroexpand-all-environment)))))))) + +(defun inline--do-quote (exp) + (pcase exp + (`(,'\, ,e) e) ;Eval `e' now *and* later. + (`'(,'\, ,e) `(list 'quote ,e)) ;Only eval `e' now, not later. + (`#'(,'\, ,e) `(list 'function ,e)) ;Only eval `e' now, not later. + ((pred consp) + (let ((args ())) + (while (and (consp exp) (not (eq '\, (car exp)))) + (push (inline--do-quote (pop exp)) args)) + (setq args (nreverse args)) + (if exp + `(backquote-list* ,@args ,(inline--do-quote exp)) + `(list ,@args)))) + (_ (macroexp-quote exp)))) + +(defun inline--dont-quote (exp) + (pcase exp + (`(,'\, ,e) e) + (`'(,'\, ,e) e) + (`#'(,'\, ,e) e) + ((pred consp) + (let ((args ())) + (while (and (consp exp) (not (eq '\, (car exp)))) + (push (inline--dont-quote (pop exp)) args)) + (setq args (nreverse args)) + (if exp + `(apply ,@args ,(inline--dont-quote exp)) + args))) + (_ exp))) + +(defun inline--do-leteval (var-exp &rest body) + `(macroexp-let2 ,(if (symbolp var-exp) #'macroexp-copyable-p #'ignore) + ,(or (car-safe var-exp) var-exp) + ,(or (car (cdr-safe var-exp)) var-exp) + ,@body)) + +(defun inline--dont-leteval (var-exp &rest body) + (if (symbolp var-exp) + (macroexp-progn body) + `(let (,var-exp) ,@body))) + +(defun inline--do-letlisteval (listvar &rest body) + ;; Here's a sample situation: + ;; (define-inline foo (arg &rest keys) + ;; (inline-letevals (arg . keys) + ;; <check-keys>)) + ;; I.e. in <check-keys> we need `keys' to contain a list of + ;; macroexp-copyable-p expressions. + (let ((bsym (make-symbol "bindings"))) + `(let* ((,bsym ()) + (,listvar (mapcar (lambda (e) + (if (macroexp-copyable-p e) e + (let ((v (make-symbol "v"))) + (push (list v e) ,bsym) + v))) + ,listvar))) + (macroexp-let* (nreverse ,bsym) + ,(macroexp-progn body))))) + +(defun inline--dont-letlisteval (_listvar &rest body) + (macroexp-progn body)) + +(defun inline--testconst-p (exp) + (macroexp-let2 macroexp-copyable-p exp exp + `(or (macroexp-const-p ,exp) + (eq (car-safe ,exp) 'function)))) + +(defun inline--alwaysconst-p (_exp) + t) + +(defun inline--getconst-val (exp) + (macroexp-let2 macroexp-copyable-p exp exp + `(cond + ((not ,(inline--testconst-p exp)) + (throw 'inline--just-use inline--form)) + ((consp ,exp) (cadr ,exp)) + (t ,exp)))) + +(defun inline--alwaysconst-val (exp) + exp) + +(defun inline--error (&rest args) + `(error ,@args)) + +(defun inline--warning (&rest _args) + `(throw 'inline--just-use + ;; FIXME: This would inf-loop by calling us right back when + ;; macroexpand-all recurses to expand inline--form. + ;; (macroexp--warn-and-return (format ,@args) + ;; inline--form) + inline--form)) + +(provide 'inline) +;;; inline.el ends here diff --git a/lisp/emacs-lisp/let-alist.el b/lisp/emacs-lisp/let-alist.el new file mode 100644 index 00000000000..ca7a904a087 --- /dev/null +++ b/lisp/emacs-lisp/let-alist.el @@ -0,0 +1,142 @@ +;;; let-alist.el --- Easily let-bind values of an assoc-list by their names -*- lexical-binding: t; -*- + +;; Copyright (C) 2014-2015 Free Software Foundation, Inc. + +;; Author: Artur Malabarba <bruce.connor.am@gmail.com> +;; Maintainer: Artur Malabarba <bruce.connor.am@gmail.com> +;; Version: 1.0.4 +;; Keywords: extensions lisp +;; Prefix: let-alist +;; Separator: - + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package offers a single macro, `let-alist'. This macro takes a +;; first argument (whose value must be an alist) and a body. +;; +;; The macro expands to a let form containing body, where each dotted +;; symbol inside body is let-bound to their cdrs in the alist. Dotted +;; symbol is any symbol starting with a `.'. Only those present in +;; the body are let-bound and this search is done at compile time. +;; +;; For instance, the following code +;; +;; (let-alist alist +;; (if (and .title .body) +;; .body +;; .site +;; .site.contents)) +;; +;; essentially expands to +;; +;; (let ((.title (cdr (assq 'title alist))) +;; (.body (cdr (assq 'body alist))) +;; (.site (cdr (assq 'site alist))) +;; (.site.contents (cdr (assq 'contents (cdr (assq 'site alist)))))) +;; (if (and .title .body) +;; .body +;; .site +;; .site.contents)) +;; +;; If you nest `let-alist' invocations, the inner one can't access +;; the variables of the outer one. You can, however, access alists +;; inside the original alist by using dots inside the symbol, as +;; displayed in the example above by the `.site.contents'. +;; +;;; Code: + + +(defun let-alist--deep-dot-search (data) + "Return alist of symbols inside DATA that start with a `.'. +Perform a deep search and return an alist where each car is the +symbol, and each cdr is the same symbol without the `.'." + (cond + ((symbolp data) + (let ((name (symbol-name data))) + (when (string-match "\\`\\." name) + ;; Return the cons cell inside a list, so it can be appended + ;; with other results in the clause below. + (list (cons data (intern (replace-match "" nil nil name))))))) + ((not (consp data)) nil) + (t (append (let-alist--deep-dot-search (car data)) + (let-alist--deep-dot-search (cdr data)))))) + +(defun let-alist--access-sexp (symbol variable) + "Return a sexp used to access SYMBOL inside VARIABLE." + (let* ((clean (let-alist--remove-dot symbol)) + (name (symbol-name clean))) + (if (string-match "\\`\\." name) + clean + (let-alist--list-to-sexp + (mapcar #'intern (nreverse (split-string name "\\."))) + variable)))) + +(defun let-alist--list-to-sexp (list var) + "Turn symbols LIST into recursive calls to `cdr' `assq' on VAR." + `(cdr (assq ',(car list) + ,(if (cdr list) (let-alist--list-to-sexp (cdr list) var) + var)))) + +(defun let-alist--remove-dot (symbol) + "Return SYMBOL, sans an initial dot." + (let ((name (symbol-name symbol))) + (if (string-match "\\`\\." name) + (intern (replace-match "" nil nil name)) + symbol))) + + +;;; The actual macro. +;;;###autoload +(defmacro let-alist (alist &rest body) + "Let-bind dotted symbols to their cdrs in ALIST and execute BODY. +Dotted symbol is any symbol starting with a `.'. Only those present +in BODY are let-bound and this search is done at compile time. + +For instance, the following code + + (let-alist alist + (if (and .title .body) + .body + .site + .site.contents)) + +essentially expands to + + (let ((.title (cdr (assq 'title alist))) + (.body (cdr (assq 'body alist))) + (.site (cdr (assq 'site alist))) + (.site.contents (cdr (assq 'contents (cdr (assq 'site alist)))))) + (if (and .title .body) + .body + .site + .site.contents)) + +If you nest `let-alist' invocations, the inner one can't access +the variables of the outer one. You can, however, access alists +inside the original alist by using dots inside the symbol, as +displayed in the example above." + (declare (indent 1) (debug t)) + (let ((var (make-symbol "alist"))) + `(let ((,var ,alist)) + (let ,(mapcar (lambda (x) `(,(car x) ,(let-alist--access-sexp (car x) var))) + (delete-dups (let-alist--deep-dot-search body))) + ,@body)))) + +(provide 'let-alist) + +;;; let-alist.el ends here diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index f2e691102d4..393f0dd99e8 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-2015 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. @@ -269,16 +265,17 @@ a section." (defun lm-header (header) "Return the contents of the header named HEADER." - (goto-char (point-min)) - (let ((case-fold-search t)) - (when (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t) - ;; RCS ident likes format "$identifier: data$" - (looking-at - (if (save-excursion - (skip-chars-backward "^$" (match-beginning 0)) - (= (point) (match-beginning 0))) - "[^\n]+" "[^$\n]+"))) - (match-string-no-properties 0)))) + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t)) + (when (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t) + ;; RCS ident likes format "$identifier: data$" + (looking-at + (if (save-excursion + (skip-chars-backward "^$" (match-beginning 0)) + (= (point) (match-beginning 0))) + "[^\n]+" "[^$\n]+"))) + (match-string-no-properties 0))))) (defun lm-header-multiline (header) "Return the contents of the header named HEADER, with continuation lines. @@ -440,8 +437,10 @@ This can be found in an RCS or SCCS header." ;; Look for an SCCS header ((re-search-forward (concat - (regexp-quote "@(#)") - (regexp-quote (file-name-nondirectory (buffer-file-name))) + "@(#)" + (if buffer-file-name + (regexp-quote (file-name-nondirectory buffer-file-name)) + "[^\t\n]+") "\t\\([012345679.]*\\)") header-max t) (match-string-no-properties 1))))))) @@ -461,8 +460,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) @@ -553,11 +552,11 @@ copyright notice is allowed." ((not (lm-keywords-finder-p)) "`Keywords:' has no valid finder keywords (see `finder-known-keywords')") ((not (lm-commentary-mark)) - "Can't find a 'Commentary' section marker") + "Can't find a `Commentary' section marker") ((not (lm-history-mark)) - "Can't find a 'History' section marker") + "Can't find a `History' section marker") ((not (lm-code-mark)) - "Can't find a 'Code' section marker") + "Can't find a `Code' section marker") ((progn (goto-char (point-max)) (not diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index f7105b7d3b4..9ce0dfd49e8 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 -*- coding: utf-8 -*- +;;; 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-2015 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, languages ;; Package: emacs @@ -28,22 +28,17 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defvar font-lock-comment-face) (defvar font-lock-doc-face) (defvar font-lock-keywords-case-fold-search) (defvar font-lock-string-face) -(defvar lisp-mode-abbrev-table nil) (define-abbrev-table 'lisp-mode-abbrev-table () "Abbrev table for Lisp mode.") -(defvar emacs-lisp-mode-abbrev-table nil) -(define-abbrev-table 'emacs-lisp-mode-abbrev-table () - "Abbrev table for Emacs Lisp mode. -It has `lisp-mode-abbrev-table' as its parent." - :parents (list lisp-mode-abbrev-table)) - -(defvar emacs-lisp-mode-syntax-table +(defvar lisp--mode-syntax-table (let ((table (make-syntax-table)) (i 0)) (while (< i ?0) @@ -74,7 +69,7 @@ It has `lisp-mode-abbrev-table' as its parent." (modify-syntax-entry ?` "' " table) (modify-syntax-entry ?' "' " table) (modify-syntax-entry ?, "' " table) - (modify-syntax-entry ?@ "' " table) + (modify-syntax-entry ?@ "_ p" table) ;; Used to be singlequote; changed for flonums. (modify-syntax-entry ?. "_ " table) (modify-syntax-entry ?# "' " table) @@ -82,13 +77,11 @@ It has `lisp-mode-abbrev-table' as its parent." (modify-syntax-entry ?\\ "\\ " table) (modify-syntax-entry ?\( "() " table) (modify-syntax-entry ?\) ")( " table) - (modify-syntax-entry ?\[ "(] " table) - (modify-syntax-entry ?\] ")[ " table) table) - "Syntax table used in `emacs-lisp-mode'.") + "Parent syntax table used in Lisp modes.") (defvar lisp-mode-syntax-table - (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) + (let ((table (make-syntax-table lisp--mode-syntax-table))) (modify-syntax-entry ?\[ "_ " table) (modify-syntax-entry ?\] "_ " table) (modify-syntax-entry ?# "' 14" table) @@ -96,47 +89,66 @@ It has `lisp-mode-abbrev-table' as its parent." table) "Syntax table used in `lisp-mode'.") +(eval-and-compile + (defconst lisp-mode-symbol-regexp "\\(?:\\sw\\|\\s_\\|\\\\.\\)+")) + (defvar lisp-imenu-generic-expression (list (list nil (purecopy (concat "^\\s-*(" (eval-when-compile (regexp-opt - '("defun" "defun*" "defsubst" "defmacro" - "defadvice" "define-skeleton" - "define-minor-mode" "define-global-minor-mode" + '("defun" "defmacro" + ;; Elisp. + "defun*" "defsubst" "define-inline" + "define-advice" "defadvice" "define-skeleton" + "define-compilation-mode" "define-minor-mode" + "define-global-minor-mode" "define-globalized-minor-mode" "define-derived-mode" "define-generic-mode" + "cl-defun" "cl-defsubst" "cl-defmacro" + "cl-define-compiler-macro" + ;; CL. "define-compiler-macro" "define-modify-macro" "defsetf" "define-setf-expander" "define-method-combination" - "defgeneric" "defmethod" - "cl-defun" "cl-defsubst" "cl-defmacro" - "cl-define-compiler-macro") t)) - "\\s-+\\(\\(\\sw\\|\\s_\\)+\\)")) + ;; CLOS and EIEIO + "defgeneric" "defmethod") + t)) + "\\s-+\\(" lisp-mode-symbol-regexp "\\)")) 2) (list (purecopy "Variables") (purecopy (concat "^\\s-*(" (eval-when-compile (regexp-opt - '("defconst" "defconstant" "defcustom" - "defparameter" "define-symbol-macro") t)) - "\\s-+\\(\\(\\sw\\|\\s_\\)+\\)")) + '(;; Elisp + "defconst" "defcustom" + ;; CL + "defconstant" + "defparameter" "define-symbol-macro") + t)) + "\\s-+\\(" lisp-mode-symbol-regexp "\\)")) 2) ;; For `defvar', we ignore (defvar FOO) constructs. (list (purecopy "Variables") - (purecopy (concat "^\\s-*(defvar\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" + (purecopy (concat "^\\s-*(defvar\\s-+\\(" lisp-mode-symbol-regexp "\\)" "[[:space:]\n]+[^)]")) 1) (list (purecopy "Types") (purecopy (concat "^\\s-*(" (eval-when-compile (regexp-opt - '("defgroup" "deftheme" "deftype" "defstruct" - "defclass" "define-condition" "define-widget" - "defface" "defpackage" "cl-deftype" - "cl-defstruct") t)) - "\\s-+'?\\(\\(\\sw\\|\\s_\\)+\\)")) + '(;; Elisp + "defgroup" "deftheme" + "define-widget" "define-error" + "defface" "cl-deftype" "cl-defstruct" + ;; CL + "deftype" "defstruct" + "define-condition" "defpackage" + ;; CLOS and EIEIO + "defclass") + t)) + "\\s-+'?\\(" lisp-mode-symbol-regexp "\\)")) 2)) "Imenu generic expression for Lisp mode. See `imenu-generic-expression'.") @@ -153,6 +165,364 @@ 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. + +(defun lisp--match-hidden-arg (limit) + (let ((res nil)) + (while + (let ((ppss (parse-partial-sexp (line-beginning-position) + (line-end-position) + -1))) + (skip-syntax-forward " )") + (if (or (>= (car ppss) 0) + (looking-at ";\\|$")) + (progn + (forward-line 1) + (< (point) limit)) + (looking-at ".*") ;Set the match-data. + (forward-line 1) + (setq res (point)) + nil))) + res)) + +(defun lisp--el-non-funcall-position-p (pos) + "Heuristically determine whether POS is an evaluated position." + (save-match-data + (save-excursion + (ignore-errors + (goto-char pos) + (or (eql (char-before) ?\') + (let* ((ppss (syntax-ppss)) + (paren-posns (nth 9 ppss)) + (parent + (when paren-posns + (goto-char (car (last paren-posns))) ;(up-list -1) + (cond + ((ignore-errors + (and (eql (char-after) ?\() + (when (cdr paren-posns) + (goto-char (car (last paren-posns 2))) + (looking-at "(\\_<let\\*?\\_>")))) + (goto-char (match-end 0)) + 'let) + ((looking-at + (rx "(" + (group-n 1 (+ (or (syntax w) (syntax _)))) + symbol-end)) + (prog1 (intern-soft (match-string-no-properties 1)) + (goto-char (match-end 1)))))))) + (or (eq parent 'declare) + (and (eq parent 'let) + (progn + (forward-sexp 1) + (< pos (point)))) + (and (eq parent 'condition-case) + (progn + (forward-sexp 2) + (< (point) pos)))))))))) + +(defun lisp--el-match-keyword (limit) + ;; FIXME: Move to elisp-mode.el. + (catch 'found + (while (re-search-forward + (eval-when-compile + (concat "(\\(" lisp-mode-symbol-regexp "\\)\\_>")) + limit t) + (let ((sym (intern-soft (match-string 1)))) + (when (or (special-form-p sym) + (and (macrop sym) + (not (get sym 'no-font-lock-keyword)) + (not (lisp--el-non-funcall-position-p + (match-beginning 0))))) + (throw 'found t)))))) + +(defmacro let-when-compile (bindings &rest body) + "Like `let*', but allow for compile time optimization. +Use BINDINGS as in regular `let*', but in BODY each usage should +be wrapped in `eval-when-compile'. +This will generate compile-time constants from BINDINGS." + (declare (indent 1) (debug let)) + (letrec ((loop + (lambda (bindings) + (if (null bindings) + (macroexpand-all (macroexp-progn body) + macroexpand-all-environment) + (let ((binding (pop bindings))) + (cl-progv (list (car binding)) + (list (eval (nth 1 binding) t)) + (funcall loop bindings))))))) + (funcall loop bindings))) + +(let-when-compile + ((lisp-fdefs '("defmacro" "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. Now they are update dynamically + ;; from obarray but they are also used for setting up + ;; the keywords for Common Lisp. + (el-fdefs '("defsubst" "cl-defsubst" "define-inline" + "define-advice" "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-errs '("user-error")) + ;; Common-Lisp constructs supported by EIEIO. FIXME: namespace. + (eieio-fdefs '("defgeneric" "defmethod")) + (eieio-tdefs '("defclass")) + ;; Common-Lisp constructs supported by cl-lib. + (cl-lib-fdefs '("defmacro" "defsubst" "defun" "defmethod" "defgeneric")) + (cl-lib-tdefs '("defstruct" "deftype")) + (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 '("block" "break" "case" "ccase" "compiler-let" "ctypecase" + "declaim" "destructuring-bind" "do" "do*" + "ecase" "etypecase" "eval-when" "flet" "flet*" + "go" "handler-case" "handler-bind" "in-package" ;; "inline" + "labels" "letf" "locally" "loop" + "macrolet" "multiple-value-bind" "multiple-value-prog1" + "proclaim" "prog" "prog*" "progv" + "restart-case" "restart-bind" "return" "return-from" + "symbol-macrolet" "tagbody" "the" "typecase" + "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-slots" "with-standard-io-syntax")) + (cl-errs '("abort" "cerror"))) + (let ((vdefs (eval-when-compile + (append lisp-vdefs el-vdefs cl-vdefs))) + (tdefs (eval-when-compile + (append el-tdefs eieio-tdefs cl-tdefs cl-lib-tdefs + (mapcar (lambda (s) (concat "cl-" s)) cl-lib-tdefs)))) + ;; Elisp and Common Lisp definers. + (el-defs-re (eval-when-compile + (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))) + (cl-defs-re (eval-when-compile + (regexp-opt (append lisp-fdefs lisp-vdefs + cl-lib-fdefs cl-lib-tdefs + eieio-fdefs eieio-tdefs + cl-fdefs cl-vdefs cl-tdefs) + t))) + ;; Common Lisp keywords (Elisp keywords are handled dynamically). + (cl-kws-re (eval-when-compile + (regexp-opt (append lisp-kw cl-kw) t))) + ;; Elisp and Common Lisp "errors". + (el-errs-re (eval-when-compile + (regexp-opt (append (mapcar (lambda (s) (concat "cl-" s)) + cl-lib-errs) + lisp-errs el-errs) + t))) + (cl-errs-re (eval-when-compile + (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']*" + "\\(([ \t']*\\)?" ;; An opening paren. + "\\(\\(setf\\)[ \t]+" lisp-mode-symbol-regexp + "\\|" lisp-mode-symbol-regexp "\\)?") + (1 font-lock-keyword-face) + (3 (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) + ;; If match-string 2 is non-nil, we encountered a + ;; form like (defalias (intern (concat s "-p"))), + ;; unless match-string 4 is also there. Then its a + ;; defmethod with (setf foo) as name. + ((or (not (match-string 2)) ;; Normal defun. + (and (match-string 2) ;; Setf method. + (match-string 4))) + 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']*" + "\\(([ \t']*\\)?" ;; An opening paren. + "\\(\\(setf\\)[ \t]+" lisp-mode-symbol-regexp + "\\|" lisp-mode-symbol-regexp "\\)?") + (1 font-lock-keyword-face) + (3 (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) + ((or (not (match-string 2)) ;; Normal defun. + (and (match-string 2) ;; Setf function. + (match-string 4))) 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. + (lisp--el-match-keyword . 1) + ;; Exit/Feature symbols as constants. + (,(concat "(\\(catch\\|throw\\|featurep\\|provide\\|require\\)\\_>" + "[ \t']*\\(" lisp-mode-symbol-regexp "\\)?") + (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'. + (,(concat "\\\\\\\\\\[\\(" lisp-mode-symbol-regexp "\\)\\]") + (1 font-lock-constant-face prepend)) + ;; Words inside ‘’ and '' and `' tend to be symbol names. + (,(concat "['`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" + lisp-mode-symbol-regexp "\\)['’]") + (1 font-lock-constant-face prepend)) + ;; Constant values. + (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") + (0 font-lock-builtin-face)) + ;; ELisp and CLisp `&' keywords as types. + (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>") + . 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) + (lisp--match-hidden-arg + (0 '(face font-lock-warning-face + help-echo "Hidden behind deeper element; move to another line?"))) + )) + "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']*\\(" lisp-mode-symbol-regexp "\\)?") + (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 ‘’ and '' and `' tend to be symbol names. + (,(concat "['`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" + lisp-mode-symbol-regexp "\\)['’]") + (1 font-lock-constant-face prepend)) + ;; Constant values. + (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") + (0 font-lock-builtin-face)) + ;; ELisp and CLisp `&' keywords as types. + (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>") + . 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) + (lisp--match-hidden-arg + (0 '(face font-lock-warning-face + help-echo "Hidden behind deeper element; move to another line?"))) + )) + "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-string-in-doc-position-p (listbeg startpos) + (let* ((firstsym (and listbeg + (save-excursion + (goto-char listbeg) + (and (looking-at + (eval-when-compile + (concat "([ \t\n]*\\(" + lisp-mode-symbol-regexp "\\)"))) + (match-string 1))))) + (docelt (and firstsym + (function-get (intern-soft firstsym) + lisp-doc-string-elt-property)))) + (and docelt + ;; It's a string in a form that can have a docstring. + ;; Check whether it's in docstring position. + (save-excursion + (when (functionp docelt) + (goto-char (match-end 1)) + (setq docelt (funcall docelt))) + (goto-char listbeg) + (forward-char 1) + (condition-case nil + (while (and (> docelt 0) (< (point) startpos) + (progn (forward-sexp 1) t)) + (setq docelt (1- docelt))) + (error nil)) + (and (zerop docelt) (<= (point) startpos) + (progn (forward-comment (point-max)) t) + (= (point) startpos)))))) + +(defun lisp-string-after-doc-keyword-p (listbeg startpos) + (and listbeg ; We are inside a Lisp form. + (save-excursion + (goto-char startpos) + (ignore-errors + (progn (backward-sexp 1) + (looking-at ":documentation\\_>")))))) + (defun lisp-font-lock-syntactic-face-function (state) (if (nth 3 state) ;; This might be a (doc)string or a |...| symbol. @@ -160,37 +530,15 @@ It has `lisp-mode-abbrev-table' as its parent." (if (eq (char-after startpos) ?|) ;; This is not a string, but a |...| symbol. nil - (let* ((listbeg (nth 1 state)) - (firstsym (and listbeg - (save-excursion - (goto-char listbeg) - (and (looking-at "([ \t\n]*\\(\\(\\sw\\|\\s_\\)+\\)") - (match-string 1))))) - (docelt (and firstsym - (function-get (intern-soft firstsym) - lisp-doc-string-elt-property)))) - (if (and docelt - ;; It's a string in a form that can have a docstring. - ;; Check whether it's in docstring position. - (save-excursion - (when (functionp docelt) - (goto-char (match-end 1)) - (setq docelt (funcall docelt))) - (goto-char listbeg) - (forward-char 1) - (condition-case nil - (while (and (> docelt 0) (< (point) startpos) - (progn (forward-sexp 1) t)) - (setq docelt (1- docelt))) - (error nil)) - (and (zerop docelt) (<= (point) startpos) - (progn (forward-comment (point-max)) t) - (= (point) (nth 8 state))))) + (let ((listbeg (nth 1 state))) + (if (or (lisp-string-in-doc-position-p listbeg startpos) + (lisp-string-after-doc-keyword-p listbeg startpos)) font-lock-doc-face 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 @@ -214,27 +562,28 @@ font-lock keywords will not be case sensitive." (setq-local outline-level 'lisp-outline-level) (setq-local add-log-current-defun-function #'lisp-current-defun-name) (setq-local comment-start ";") - ;; Look within the line for a ; following an even number of backslashes - ;; after either a non-backslash or the line beginning. - (setq-local comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") - ;; Font lock mode uses this only when it KNOWS a comment is starting. - (setq-local font-lock-comment-start-skip ";+ *") + (setq-local comment-start-skip ";+ *") (setq-local comment-add 1) ;default to `;;' in comment-region (setq-local comment-column 40) - ;; Don't get confused by `;' in doc strings when paragraph-filling. - (setq-local comment-use-global-state t) + (setq-local comment-use-syntax 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-extra-managed-props help-echo) (font-lock-syntactic-face-function . lisp-font-lock-syntactic-face-function))) - (setq-local prettify-symbols-alist lisp--prettify-symbols-alist)) + (setq-local prettify-symbols-alist lisp--prettify-symbols-alist) + (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." @@ -281,166 +630,6 @@ font-lock keywords will not be case sensitive." map) "Keymap for commands shared by all sorts of Lisp modes.") -(defvar emacs-lisp-mode-map - (let ((map (make-sparse-keymap "Emacs-Lisp")) - (menu-map (make-sparse-keymap "Emacs-Lisp")) - (lint-map (make-sparse-keymap)) - (prof-map (make-sparse-keymap)) - (tracing-map (make-sparse-keymap))) - (set-keymap-parent map lisp-mode-shared-map) - (define-key map "\e\t" 'completion-at-point) - (define-key map "\e\C-x" 'eval-defun) - (define-key map "\e\C-q" 'indent-pp-sexp) - (bindings--define-key map [menu-bar emacs-lisp] - (cons "Emacs-Lisp" menu-map)) - (bindings--define-key menu-map [eldoc] - '(menu-item "Auto-Display Documentation Strings" eldoc-mode - :button (:toggle . (bound-and-true-p eldoc-mode)) - :help "Display the documentation string for the item under cursor")) - (bindings--define-key menu-map [checkdoc] - '(menu-item "Check Documentation Strings" checkdoc - :help "Check documentation strings for style requirements")) - (bindings--define-key menu-map [re-builder] - '(menu-item "Construct Regexp" re-builder - :help "Construct a regexp interactively")) - (bindings--define-key menu-map [tracing] (cons "Tracing" tracing-map)) - (bindings--define-key tracing-map [tr-a] - '(menu-item "Untrace All" untrace-all - :help "Untrace all currently traced functions")) - (bindings--define-key tracing-map [tr-uf] - '(menu-item "Untrace Function..." untrace-function - :help "Untrace function, and possibly activate all remaining advice")) - (bindings--define-key tracing-map [tr-sep] menu-bar-separator) - (bindings--define-key tracing-map [tr-q] - '(menu-item "Trace Function Quietly..." trace-function-background - :help "Trace the function with trace output going quietly to a buffer")) - (bindings--define-key tracing-map [tr-f] - '(menu-item "Trace Function..." trace-function - :help "Trace the function given as an argument")) - (bindings--define-key menu-map [profiling] (cons "Profiling" prof-map)) - (bindings--define-key prof-map [prof-restall] - '(menu-item "Remove Instrumentation for All Functions" elp-restore-all - :help "Restore the original definitions of all functions being profiled")) - (bindings--define-key prof-map [prof-restfunc] - '(menu-item "Remove Instrumentation for Function..." elp-restore-function - :help "Restore an instrumented function to its original definition")) - - (bindings--define-key prof-map [sep-rem] menu-bar-separator) - (bindings--define-key prof-map [prof-resall] - '(menu-item "Reset Counters for All Functions" elp-reset-all - :help "Reset the profiling information for all functions being profiled")) - (bindings--define-key prof-map [prof-resfunc] - '(menu-item "Reset Counters for Function..." elp-reset-function - :help "Reset the profiling information for a function")) - (bindings--define-key prof-map [prof-res] - '(menu-item "Show Profiling Results" elp-results - :help "Display current profiling results")) - (bindings--define-key prof-map [prof-pack] - '(menu-item "Instrument Package..." elp-instrument-package - :help "Instrument for profiling all function that start with a prefix")) - (bindings--define-key prof-map [prof-func] - '(menu-item "Instrument Function..." elp-instrument-function - :help "Instrument a function for profiling")) - ;; Maybe this should be in a separate submenu from the ELP stuff? - (bindings--define-key prof-map [sep-natprof] menu-bar-separator) - (bindings--define-key prof-map [prof-natprof-stop] - '(menu-item "Stop Native Profiler" profiler-stop - :help "Stop recording profiling information" - :enable (and (featurep 'profiler) - (profiler-running-p)))) - (bindings--define-key prof-map [prof-natprof-report] - '(menu-item "Show Profiler Report" profiler-report - :help "Show the current profiler report" - :enable (and (featurep 'profiler) - (profiler-running-p)))) - (bindings--define-key prof-map [prof-natprof-start] - '(menu-item "Start Native Profiler..." profiler-start - :help "Start recording profiling information")) - - (bindings--define-key menu-map [lint] (cons "Linting" lint-map)) - (bindings--define-key lint-map [lint-di] - '(menu-item "Lint Directory..." elint-directory - :help "Lint a directory")) - (bindings--define-key lint-map [lint-f] - '(menu-item "Lint File..." elint-file - :help "Lint a file")) - (bindings--define-key lint-map [lint-b] - '(menu-item "Lint Buffer" elint-current-buffer - :help "Lint the current buffer")) - (bindings--define-key lint-map [lint-d] - '(menu-item "Lint Defun" elint-defun - :help "Lint the function at point")) - (bindings--define-key menu-map [edebug-defun] - '(menu-item "Instrument Function for Debugging" edebug-defun - :help "Evaluate the top level form point is in, stepping through with Edebug" - :keys "C-u C-M-x")) - (bindings--define-key menu-map [separator-byte] menu-bar-separator) - (bindings--define-key menu-map [disas] - '(menu-item "Disassemble Byte Compiled Object..." disassemble - :help "Print disassembled code for OBJECT in a buffer")) - (bindings--define-key menu-map [byte-recompile] - '(menu-item "Byte-recompile Directory..." byte-recompile-directory - :help "Recompile every `.el' file in DIRECTORY that needs recompilation")) - (bindings--define-key menu-map [emacs-byte-compile-and-load] - '(menu-item "Byte-compile and Load" emacs-lisp-byte-compile-and-load - :help "Byte-compile the current file (if it has changed), then load compiled code")) - (bindings--define-key menu-map [byte-compile] - '(menu-item "Byte-compile This File" emacs-lisp-byte-compile - :help "Byte compile the file containing the current buffer")) - (bindings--define-key menu-map [separator-eval] menu-bar-separator) - (bindings--define-key menu-map [ielm] - '(menu-item "Interactive Expression Evaluation" ielm - :help "Interactively evaluate Emacs Lisp expressions")) - (bindings--define-key menu-map [eval-buffer] - '(menu-item "Evaluate Buffer" eval-buffer - :help "Execute the current buffer as Lisp code")) - (bindings--define-key menu-map [eval-region] - '(menu-item "Evaluate Region" eval-region - :help "Execute the region as Lisp code" - :enable mark-active)) - (bindings--define-key menu-map [eval-sexp] - '(menu-item "Evaluate Last S-expression" eval-last-sexp - :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 - :help "Comment or uncomment each line in the region" - :enable mark-active)) - (bindings--define-key menu-map [indent-region] - '(menu-item "Indent Region" indent-region - :help "Indent each nonblank line in the region" - :enable mark-active)) - (bindings--define-key menu-map [indent-line] - '(menu-item "Indent Line" lisp-indent-line)) - map) - "Keymap for Emacs Lisp mode. -All commands in `lisp-mode-shared-map' are inherited by this map.") - -(defun emacs-lisp-byte-compile () - "Byte compile the file containing the current buffer." - (interactive) - (if buffer-file-name - (byte-compile-file buffer-file-name) - (error "The buffer must be saved in a file first"))) - -(defun emacs-lisp-byte-compile-and-load () - "Byte-compile the current file (if it has changed), then load compiled code." - (interactive) - (or buffer-file-name - (error "The buffer must be saved in a file first")) - (require 'bytecomp) - ;; Recompile if file or buffer has changed since last compilation. - (if (and (buffer-modified-p) - (y-or-n-p (format "Save buffer %s first? " (buffer-name)))) - (save-buffer)) - (byte-recompile-file buffer-file-name nil 0 t)) - -(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) - :type 'hook - :group 'lisp) - (defcustom lisp-mode-hook nil "Hook run when entering Lisp mode." :options '(imenu-add-menubar-index) @@ -449,81 +638,13 @@ 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." - :group 'lisp - (lisp-mode-variables) - (setq imenu-case-fold-search nil) - (add-hook 'completion-at-point-functions - 'lisp-completion-at-point nil 'local)) - -;;; Emacs Lisp Byte-Code mode - -(eval-and-compile - (defconst emacs-list-byte-code-comment-re - (concat "\\(#\\)@\\([0-9]+\\) " - ;; Make sure it's a docstring and not a lazy-loaded byte-code. - "\\(?:[^(]\\|([^\"]\\)"))) - -(defun emacs-lisp-byte-code-comment (end &optional _point) - "Try to syntactically mark the #@NNN ....^_ docstrings in byte-code files." - (let ((ppss (syntax-ppss))) - (when (and (nth 4 ppss) - (eq (char-after (nth 8 ppss)) ?#)) - (let* ((n (save-excursion - (goto-char (nth 8 ppss)) - (when (looking-at emacs-list-byte-code-comment-re) - (string-to-number (match-string 2))))) - ;; `maxdiff' tries to make sure the loop below terminates. - (maxdiff n)) - (when n - (let* ((bchar (match-end 2)) - (b (position-bytes bchar))) - (goto-char (+ b n)) - (while (let ((diff (- (position-bytes (point)) b n))) - (unless (zerop diff) - (when (> diff maxdiff) (setq diff maxdiff)) - (forward-char (- diff)) - (setq maxdiff (if (> diff 0) diff - (max (1- maxdiff) 1))) - t)))) - (if (<= (point) end) - (put-text-property (1- (point)) (point) - 'syntax-table - (string-to-syntax "> b")) - (goto-char end))))))) - -(defun emacs-lisp-byte-code-syntax-propertize (start end) - (emacs-lisp-byte-code-comment end (point)) - (funcall - (syntax-propertize-rules - (emacs-list-byte-code-comment-re - (1 (prog1 "< b" (emacs-lisp-byte-code-comment end (point)))))) - start end)) - -(add-to-list 'auto-mode-alist '("\\.elc\\'" . emacs-lisp-byte-code-mode)) -(define-derived-mode emacs-lisp-byte-code-mode emacs-lisp-mode - "Elisp-Byte-Code" - "Major mode for *.elc files." - ;; TODO: Add way to disassemble byte-code under point. - (setq-local open-paren-in-column-0-is-defun-start nil) - (setq-local syntax-propertize-function - #'emacs-lisp-byte-code-syntax-propertize)) - ;;; Generic Lisp mode. (defvar lisp-mode-map @@ -554,10 +675,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 @@ -580,407 +698,6 @@ if that value is non-nil." (interactive) (error "Process lisp does not exist")) -(defvar lisp-interaction-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap "Lisp-Interaction"))) - (set-keymap-parent map lisp-mode-shared-map) - (define-key map "\e\C-x" 'eval-defun) - (define-key map "\e\C-q" 'indent-pp-sexp) - (define-key map "\e\t" 'completion-at-point) - (define-key map "\n" 'eval-print-last-sexp) - (bindings--define-key map [menu-bar lisp-interaction] - (cons "Lisp-Interaction" menu-map)) - (bindings--define-key menu-map [eval-defun] - '(menu-item "Evaluate Defun" eval-defun - :help "Evaluate the top-level form containing point, or after point")) - (bindings--define-key menu-map [eval-print-last-sexp] - '(menu-item "Evaluate and Print" eval-print-last-sexp - :help "Evaluate sexp before point; print value into current buffer")) - (bindings--define-key menu-map [edebug-defun-lisp-interaction] - '(menu-item "Instrument Function for Debugging" edebug-defun - :help "Evaluate the top level form point is in, stepping through with Edebug" - :keys "C-u C-M-x")) - (bindings--define-key menu-map [indent-pp-sexp] - '(menu-item "Indent or Pretty-Print" indent-pp-sexp - :help "Indent each line of the list starting just after point, or prettyprint it")) - (bindings--define-key menu-map [complete-symbol] - '(menu-item "Complete Lisp Symbol" completion-at-point - :help "Perform completion on Lisp symbol preceding point")) - map) - "Keymap for Lisp Interaction mode. -All commands in `lisp-mode-shared-map' are inherited by this map.") - -(define-derived-mode lisp-interaction-mode emacs-lisp-mode "Lisp Interaction" - "Major mode for typing and evaluating Lisp forms. -Like Lisp mode except that \\[eval-print-last-sexp] evals the Lisp expression -before point, and prints its value into the buffer, advancing point. -Note that printing is controlled by `eval-expression-print-length' -and `eval-expression-print-level'. - -Commands: -Delete converts tabs to spaces as it moves back. -Paragraphs are separated only by blank lines. -Semicolons start comments. - -\\{lisp-interaction-mode-map} -Entry to this mode calls the value of `lisp-interaction-mode-hook' -if that value is non-nil." - :abbrev-table nil) - -(defun eval-print-last-sexp () - "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. - -Note that printing the result is controlled by the variables -`eval-expression-print-length' and `eval-expression-print-level', -which see." - (interactive) - (let ((standard-output (current-buffer))) - (terpri) - (eval-last-sexp t) - (terpri))) - - -(defun last-sexp-setup-props (beg end value alt1 alt2) - "Set up text properties for the output of `eval-last-sexp-1'. -BEG and END are the start and end of the output in current-buffer. -VALUE is the Lisp value printed, ALT1 and ALT2 are strings for the -alternative printed representations that can be displayed." - (let ((map (make-sparse-keymap))) - (define-key map "\C-m" 'last-sexp-toggle-display) - (define-key map [down-mouse-2] 'mouse-set-point) - (define-key map [mouse-2] 'last-sexp-toggle-display) - (add-text-properties - beg end - `(printed-value (,value ,alt1 ,alt2) - mouse-face highlight - keymap ,map - help-echo "RET, mouse-2: toggle abbreviated display" - rear-nonsticky (mouse-face keymap help-echo - printed-value))))) - - -(defun last-sexp-toggle-display (&optional _arg) - "Toggle between abbreviated and unabbreviated printed representations." - (interactive "P") - (save-restriction - (widen) - (let ((value (get-text-property (point) 'printed-value))) - (when value - (let ((beg (or (previous-single-property-change (min (point-max) (1+ (point))) - 'printed-value) - (point))) - (end (or (next-single-char-property-change (point) 'printed-value) (point))) - (standard-output (current-buffer)) - (point (point))) - (delete-region beg end) - (insert (nth 1 value)) - (or (= beg point) - (setq point (1- (point)))) - (last-sexp-setup-props beg (point) - (nth 0 value) - (nth 2 value) - (nth 1 value)) - (goto-char (min (point-max) point))))))) - -(defun prin1-char (char) - "Return a string representing CHAR as a character rather than as an integer. -If CHAR is not a character, return nil." - (and (integerp char) - (eventp char) - (let ((c (event-basic-type char)) - (mods (event-modifiers char)) - string) - ;; Prevent ?A from turning into ?\S-a. - (if (and (memq 'shift mods) - (zerop (logand char ?\S-\^@)) - (not (let ((case-fold-search nil)) - (char-equal c (upcase c))))) - (setq c (upcase c) mods nil)) - ;; What string are we considering using? - (condition-case nil - (setq string - (concat - "?" - (mapconcat - (lambda (modif) - (cond ((eq modif 'super) "\\s-") - (t (string ?\\ (upcase (aref (symbol-name modif) 0)) ?-)))) - mods "") - (cond - ((memq c '(?\; ?\( ?\) ?\{ ?\} ?\[ ?\] ?\" ?\' ?\\)) (string ?\\ c)) - ((eq c 127) "\\C-?") - (t - (string c))))) - (error nil)) - ;; Verify the string reads a CHAR, not to some other character. - ;; If it doesn't, return nil instead. - (and string - (= (car (read-from-string string)) char) - string)))) - - -(defun preceding-sexp () - "Return sexp before the point." - (let ((opoint (point)) - ignore-quotes - expr) - (save-excursion - (with-syntax-table emacs-lisp-mode-syntax-table - ;; If this sexp appears to be enclosed in `...' - ;; then ignore the surrounding quotes. - (setq ignore-quotes - (or (eq (following-char) ?\') - (eq (preceding-char) ?\'))) - (forward-sexp -1) - ;; If we were after `?\e' (or similar case), - ;; use the whole thing, not just the `e'. - (when (eq (preceding-char) ?\\) - (forward-char -1) - (when (eq (preceding-char) ??) - (forward-char -1))) - - ;; Skip over hash table read syntax. - (and (> (point) (1+ (point-min))) - (looking-back "#s" (- (point) 2)) - (forward-char -2)) - - ;; Skip over `#N='s. - (when (eq (preceding-char) ?=) - (let (labeled-p) - (save-excursion - (skip-chars-backward "0-9#=") - (setq labeled-p (looking-at "\\(#[0-9]+=\\)+"))) - (when labeled-p - (forward-sexp -1)))) - - (save-restriction - ;; vladimir@cs.ualberta.ca 30-Jul-1997: skip ` in - ;; `variable' so that the value is returned, not the - ;; name - (if (and ignore-quotes - (eq (following-char) ?`)) - (forward-char)) - (narrow-to-region (point-min) opoint) - (setq expr (read (current-buffer))) - ;; If it's an (interactive ...) form, it's more - ;; useful to show how an interactive call would - ;; use it. - (and (consp expr) - (eq (car expr) 'interactive) - (setq expr - (list 'call-interactively - (list 'quote - (list 'lambda - '(&rest args) - expr - 'args))))) - expr))))) - - -(defun eval-last-sexp-1 (eval-last-sexp-arg-internal) - "Evaluate sexp before point; print value in the echo area. -With argument, print output into current buffer." - (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) - ;; Setup the lexical environment if lexical-binding is enabled. - (eval-last-sexp-print-value - (eval (eval-sexp-add-defvars (preceding-sexp)) lexical-binding)))) - - -(defun eval-last-sexp-print-value (value) - (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) - (beg (point)) - end) - (prog1 - (prin1 value) - (let ((str (eval-expression-print-format value))) - (if str (princ str))) - (setq end (point)) - (when (and (bufferp standard-output) - (or (not (null print-length)) - (not (null print-level))) - (not (string= unabbreviated - (buffer-substring-no-properties beg end)))) - (last-sexp-setup-props beg end value - unabbreviated - (buffer-substring-no-properties beg end)) - )))) - - -(defvar eval-last-sexp-fake-value (make-symbol "t")) - -(defun eval-sexp-add-defvars (exp &optional pos) - "Prepend EXP with all the `defvar's that precede it in the buffer. -POS specifies the starting position where EXP was found and defaults to point." - (setq exp (macroexpand-all exp)) ;Eager macro-expansion. - (if (not lexical-binding) - exp - (save-excursion - (unless pos (setq pos (point))) - (let ((vars ())) - (goto-char (point-min)) - (while (re-search-forward - "(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)" - pos t) - (let ((var (intern (match-string 1)))) - (and (not (special-variable-p var)) - (save-excursion - (zerop (car (syntax-ppss (match-beginning 0))))) - (push var vars)))) - `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp))))) - -(defun eval-last-sexp (eval-last-sexp-arg-internal) - "Evaluate sexp before point; print value in 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'. - -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") - (if (null eval-expression-debug-on-error) - (eval-last-sexp-1 eval-last-sexp-arg-internal) - (let ((value - (let ((debug-on-error eval-last-sexp-fake-value)) - (cons (eval-last-sexp-1 eval-last-sexp-arg-internal) - debug-on-error)))) - (unless (eq (cdr value) eval-last-sexp-fake-value) - (setq debug-on-error (cdr value))) - (car value)))) - -(defun eval-defun-1 (form) - "Treat some expressions specially. -Reset the `defvar' and `defcustom' variables to the initial value. -\(For `defcustom', use the :set function if there is one.) -Reinitialize the face according to the `defface' specification." - ;; The code in edebug-defun should be consistent with this, but not - ;; the same, since this gets a macroexpanded form. - (cond ((not (listp form)) - form) - ((and (eq (car form) 'defvar) - (cdr-safe (cdr-safe form)) - (boundp (cadr form))) - ;; Force variable to be re-set. - `(progn (defvar ,(nth 1 form) nil ,@(nthcdr 3 form)) - (setq-default ,(nth 1 form) ,(nth 2 form)))) - ;; `defcustom' is now macroexpanded to - ;; `custom-declare-variable' with a quoted value arg. - ((and (eq (car form) 'custom-declare-variable) - (default-boundp (eval (nth 1 form) lexical-binding))) - ;; Force variable to be bound, using :set function if specified. - (let ((setfunc (memq :set form))) - (when setfunc - (setq setfunc (car-safe (cdr-safe setfunc))) - (or (functionp setfunc) (setq setfunc nil))) - (funcall (or setfunc 'set-default) - (eval (nth 1 form) lexical-binding) - ;; The second arg is an expression that evaluates to - ;; an expression. The second evaluation is the one - ;; normally performed not by normal execution but by - ;; custom-initialize-set (for example), which does not - ;; use lexical-binding. - (eval (eval (nth 2 form) lexical-binding)))) - form) - ;; `defface' is macroexpanded to `custom-declare-face'. - ((eq (car form) 'custom-declare-face) - ;; Reset the face. - (let ((face-symbol (eval (nth 1 form) lexical-binding))) - (setq face-new-frame-defaults - (assq-delete-all face-symbol face-new-frame-defaults)) - (put face-symbol 'face-defface-spec nil) - (put face-symbol 'face-override-spec nil)) - form) - ((eq (car form) 'progn) - (cons 'progn (mapcar 'eval-defun-1 (cdr form)))) - (t form))) - -(defun eval-defun-2 () - "Evaluate defun that point is in or before. -The value is displayed in the 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.\) - -Return the result of evaluation." - ;; FIXME: the print-length/level bindings should only be applied while - ;; printing, not while evaluating. - (let ((debug-on-error eval-expression-debug-on-error) - (print-length eval-expression-print-length) - (print-level eval-expression-print-level)) - (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)))))) - ;; The result of evaluation has been put onto VALUES. So return it. - (car values)) - -(defun eval-defun (edebug-it) - "Evaluate the top-level form containing point, or after point. - -If the current defun is actually a call to `defvar' or `defcustom', -evaluating it this way resets the variable using its initial value -expression (using the defcustom's :set function if there is one), even -if the variable already has some other value. \(Normally `defvar' and -`defcustom' do not alter the value if there already is one.) In an -analogous way, evaluating a `defface' overrides any customizations of -the face, so that it becomes defined exactly as the `defface' expression -says. - -If `eval-expression-debug-on-error' is non-nil, which is the default, -this command arranges for all errors to enter the debugger. - -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 echo area. If not -instrumented, just FUNCTION is printed. - -If not acting on a `defun', the result of evaluation is displayed in -the echo area. This display is controlled by the variables -`eval-expression-print-length' and `eval-expression-print-level', -which see." - (interactive "P") - (cond (edebug-it - (require 'edebug) - (eval-defun (not edebug-all-defs))) - (t - (if (null eval-expression-debug-on-error) - (eval-defun-2) - (let ((old-value (make-symbol "t")) new-value value) - (let ((debug-on-error old-value)) - (setq value (eval-defun-2)) - (setq new-value debug-on-error)) - (unless (eq old-value new-value) - (setq debug-on-error new-value)) - value))))) - ;; May still be used by some external Lisp-mode variant. (define-obsolete-function-alias 'lisp-comment-indent 'comment-indent-default "22.1") @@ -1147,9 +864,10 @@ is the buffer position of the start of the containing expression." ;; Handle prefix characters and whitespace ;; following an open paren. (Bug#1012) (backward-prefix-chars) - (while (and (not (looking-back "^[ \t]*\\|([ \t]+")) - (or (not containing-sexp) - (< (1+ containing-sexp) (point)))) + (while (not (or (looking-back "^[ \t]*\\|([ \t]+" + (line-beginning-position)) + (and containing-sexp + (>= (1+ containing-sexp) (point))))) (forward-sexp -1) (backward-prefix-chars)) (setq calculate-lisp-indent-last-sexp (point))) @@ -1190,7 +908,7 @@ property `lisp-indent-function' (or the deprecated `lisp-indent-hook'), it specifies how to indent. The property value can be: * `defun', meaning indent `defun'-style - \(this is also the case if there is no property and the function + (this is also the case if there is no property and the function has a name that begins with \"def\", and three or more arguments); * an integer N, meaning indent the first N arguments specially @@ -1303,19 +1021,21 @@ Lisp function does not specify a special indentation." ;; like defun if the first form is placed on the next line, otherwise ;; it is indented like any other form (i.e. forms line up under first). -(put 'autoload 'lisp-indent-function 'defun) +(put 'autoload 'lisp-indent-function 'defun) ;Elisp (put 'progn 'lisp-indent-function 0) (put 'prog1 'lisp-indent-function 1) (put 'prog2 'lisp-indent-function 2) -(put 'save-excursion 'lisp-indent-function 0) -(put 'save-restriction 'lisp-indent-function 0) -(put 'save-current-buffer 'lisp-indent-function 0) +(put 'save-excursion 'lisp-indent-function 0) ;Elisp +(put 'save-restriction 'lisp-indent-function 0) ;Elisp +(put 'save-current-buffer 'lisp-indent-function 0) ;Elisp (put 'let 'lisp-indent-function 1) (put 'let* 'lisp-indent-function 1) (put 'while 'lisp-indent-function 1) (put 'if 'lisp-indent-function 2) (put 'catch 'lisp-indent-function 1) (put 'condition-case 'lisp-indent-function 2) +(put 'handler-case 'lisp-indent-function 1) ;CL +(put 'handler-bind 'lisp-indent-function 1) ;CL (put 'unwind-protect 'lisp-indent-function 1) (put 'with-output-to-temp-buffer 'lisp-indent-function 1) diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index b37a811b8d5..ca977db4b1d 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -1,9 +1,9 @@ ;;; 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-2015 Free Software Foundation, ;; Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, languages ;; Package: emacs @@ -57,10 +57,14 @@ Should take the same arguments and behave similarly to `forward-sexp'.") (defun forward-sexp (&optional arg) "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. -Calls `forward-sexp-function' to do the work, if that is non-nil." +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. Calls +`forward-sexp-function' to do the work, if that is non-nil. If +unable to move over a sexp, signal `scan-error' with three +arguments: a message, the start of the obstacle (usually a +parenthesis or list marker of some kind), and end of the +obstacle." (interactive "^p") (or arg (setq arg 1)) (if forward-sexp-function @@ -106,6 +110,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." @@ -115,6 +121,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." @@ -124,6 +132,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." @@ -134,34 +144,92 @@ This command assumes point is not in a string or comment." (goto-char (or (scan-lists (point) inc -1) (buffer-end arg))) (setq arg (- arg inc))))) -(defun backward-up-list (&optional arg) +(defun backward-up-list (&optional arg escape-strings no-syntax-crossing) "Move backward out of one level of parentheses. -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." - (interactive "^p") - (up-list (- (or arg 1)))) - -(defun up-list (&optional arg) +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. If ESCAPE-STRINGS is non-nil (as it is +interactively), move out of enclosing strings as well. If +NO-SYNTAX-CROSSING is non-nil (as it is interactively), prefer to +break out of any enclosing string instead of moving to the start +of a list broken across multiple strings. On error, location of +point is unspecified." + (interactive "^p\nd\nd") + (up-list (- (or arg 1)) escape-strings no-syntax-crossing)) + +(defun up-list (&optional arg escape-strings no-syntax-crossing) "Move forward out of one level of parentheses. -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." - (interactive "^p") +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. If ESCAPE-STRINGS is non-nil (as it is +interactively), move out of enclosing strings as well. If +NO-SYNTAX-CROSSING is non-nil (as it is interactively), prefer to +break out of any enclosing string instead of moving to the start +of a list broken across multiple strings. On error, location of +point is unspecified." + (interactive "^p\nd\nd") (or arg (setq arg 1)) (let ((inc (if (> arg 0) 1 -1)) - pos) + (pos nil)) (while (/= arg 0) - (if (null forward-sexp-function) - (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))) - (condition-case err - (while (progn (setq pos (point)) - (forward-sexp inc) - (/= (point) pos))) - (scan-error (goto-char (nth (if (> arg 0) 3 2) err)))) - (if (= (point) pos) - (signal 'scan-error - (list "Unbalanced parentheses" (point) (point))))) + (condition-case err + (save-restriction + ;; If we've been asked not to cross string boundaries + ;; and we're inside a string, narrow to that string so + ;; that scan-lists doesn't find a match in a different + ;; string. + (when no-syntax-crossing + (let* ((syntax (syntax-ppss)) + (string-comment-start (nth 8 syntax))) + (when string-comment-start + (save-excursion + (goto-char string-comment-start) + (narrow-to-region + (point) + (if (nth 3 syntax) ; in string + (condition-case nil + (progn (forward-sexp) (point)) + (scan-error (point-max))) + (forward-comment 1) + (point))))))) + (if (null forward-sexp-function) + (goto-char (or (scan-lists (point) inc 1) + (buffer-end arg))) + (condition-case err + (while (progn (setq pos (point)) + (forward-sexp inc) + (/= (point) pos))) + (scan-error (goto-char (nth (if (> arg 0) 3 2) err)))) + (if (= (point) pos) + (signal 'scan-error + (list "Unbalanced parentheses" (point) (point)))))) + (scan-error + (let ((syntax nil)) + (or + ;; If we bumped up against the end of a list, see whether + ;; we're inside a string: if so, just go to the beginning + ;; or end of that string. + (and escape-strings + (or syntax (setf syntax (syntax-ppss))) + (nth 3 syntax) + (goto-char (nth 8 syntax)) + (progn (when (> inc 0) + (forward-sexp)) + t)) + ;; If we narrowed to a comment above and failed to escape + ;; it, the error might be our fault, not an indication + ;; that we're out of syntax. Try again from beginning or + ;; end of the comment. + (and no-syntax-crossing + (or syntax (setf syntax (syntax-ppss))) + (nth 4 syntax) + (goto-char (nth 8 syntax)) + (or (< inc 0) + (forward-comment 1)) + (setf arg (+ arg inc))) + (signal (car err) (cdr err)))))) (setq arg (- arg inc))))) (defun kill-sexp (&optional arg) @@ -195,7 +263,7 @@ This command assumes point is not in a string or comment." (backward-up-list arg) (kill-sexp) (insert current-sexp)) - (error "Not at a sexp")))) + (user-error "Not at a sexp")))) (defvar beginning-of-defun-function nil "If non-nil, function for `beginning-of-defun-raw' to call. @@ -296,8 +364,7 @@ is called as a function to find the defun's beginning." (arg-+ve (> arg 0))) (save-restriction (widen) - (let ((ppss (let (syntax-begin-function - font-lock-beginning-of-syntax-function) + (let ((ppss (let (syntax-begin-function) (syntax-ppss))) ;; position of least enclosing paren, or nil. encl-pos) @@ -363,16 +430,18 @@ is called as a function to find the defun's end." (push-mark)) (if (or (null arg) (= arg 0)) (setq arg 1)) (let ((pos (point)) - (beg (progn (end-of-line 1) (beginning-of-defun-raw 1) (point)))) + (beg (progn (end-of-line 1) (beginning-of-defun-raw 1) (point))) + (skip (lambda () + ;; When comparing point against pos, we want to consider that if + ;; point was right after the end of the function, it's still + ;; considered as "in that function". + ;; E.g. `eval-defun' from right after the last close-paren. + (unless (bolp) + (skip-chars-forward " \t") + (if (looking-at "\\s<\\|\n") + (forward-line 1)))))) (funcall end-of-defun-function) - ;; When comparing point against pos, we want to consider that if - ;; point was right after the end of the function, it's still - ;; considered as "in that function". - ;; E.g. `eval-defun' from right after the last close-paren. - (unless (bolp) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1))) + (funcall skip) (cond ((> arg 0) ;; Moving forward. @@ -395,11 +464,19 @@ is called as a function to find the defun's end." (goto-char beg)) (unless (zerop arg) (beginning-of-defun-raw (- arg)) + (setq beg (point)) (funcall end-of-defun-function)))) - (unless (bolp) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1))))) + (funcall skip) + (while (and (< arg 0) (>= (point) pos)) + ;; We intended to move backward, but this ended up not doing so: + ;; Try harder! + (goto-char beg) + (beginning-of-defun-raw (- arg)) + (if (>= (point) beg) + (setq arg 0) + (setq beg (point)) + (funcall end-of-defun-function) + (funcall skip))))) (defun mark-defun (&optional allow-extend) "Put mark at end of this defun, point at beginning. @@ -444,11 +521,15 @@ 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) +(defvar narrow-to-defun-include-comments nil + "If non-nil, `narrow-to-defun' will also show comments preceding the defun.") + +(defun narrow-to-defun (&optional include-comments) "Make text outside current defun invisible. -The defun visible is the one that contains point or follows point. -Optional ARG is ignored." - (interactive) +The current defun is the one that contains point or follows point. +Preceding comments are included if INCLUDE-COMMENTS is non-nil. +Interactively, the behavior depends on `narrow-to-defun-include-comments'." + (interactive (list narrow-to-defun-include-comments)) (save-excursion (widen) (let ((opoint (point)) @@ -484,6 +565,18 @@ Optional ARG is ignored." (setq end (point)) (beginning-of-defun) (setq beg (point))) + (when include-comments + (goto-char beg) + ;; Move back past all preceding comments (and whitespace). + (when (forward-comment -1) + (while (forward-comment -1)) + ;; Move forwards past any page breaks within these comments. + (when (and page-delimiter (not (string= page-delimiter ""))) + (while (re-search-forward page-delimiter beg t))) + ;; Lastly, move past any empty lines. + (skip-chars-forward "[:space:]\n") + (beginning-of-line) + (setq beg (point)))) (goto-char end) (re-search-backward "^\n" (- (point) 1) t) (narrow-to-region beg end)))) @@ -620,7 +713,8 @@ character." (condition-case data ;; Buffer can't have more than (point-max) sexps. (scan-sexps (point-min) (point-max)) - (scan-error (goto-char (nth 2 data)) + (scan-error (push-mark) + (goto-char (nth 2 data)) ;; Could print (nth 1 data), which is either ;; "Containing expression ends prematurely" or ;; "Unbalanced parentheses", but those may not be so @@ -641,22 +735,20 @@ character." ) (call-interactively 'minibuffer-complete))) -(defun lisp-complete-symbol (&optional predicate) +(defun lisp-complete-symbol (&optional _predicate) "Perform completion on Lisp symbol preceding point. Compare that symbol against the known Lisp symbols. If no characters can be completed, display a list of possible completions. Repeating the command at that point scrolls the list. -When called from a program, optional arg PREDICATE is a predicate -determining which symbols are considered, e.g. `commandp'. -If PREDICATE is nil, the context determines which symbols are -considered. If the symbol starts just after an open-parenthesis, only -symbols with function definitions are considered. Otherwise, all -symbols with function definitions, values or properties are -considered." - (declare (obsolete completion-at-point "24.4")) +The context determines which symbols are considered. If the +symbol starts just after an open-parenthesis, only symbols with +function definitions are considered. Otherwise, all symbols with +function definitions, values or properties are considered." + (declare (obsolete completion-at-point "24.4") + (advertised-calling-convention () "25.1")) (interactive) - (let* ((data (lisp-completion-at-point predicate)) + (let* ((data (elisp-completion-at-point)) (plist (nthcdr 3 data))) (if (null data) (minibuffer-message "Nothing to complete") @@ -664,164 +756,4 @@ considered." (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data) (plist-get plist :predicate)))))) -(defun lisp--local-variables-1 (vars sexp) - "Return the vars locally bound around the witness, or nil if not found." - (let (res) - (while - (unless - (setq res - (pcase sexp - (`(,(or `let `let*) ,bindings) - (let ((vars vars)) - (when (eq 'let* (car sexp)) - (dolist (binding (cdr (reverse bindings))) - (push (or (car-safe binding) binding) vars))) - (lisp--local-variables-1 - vars (car (cdr-safe (car (last bindings))))))) - (`(,(or `let `let*) ,bindings . ,body) - (let ((vars vars)) - (dolist (binding bindings) - (push (or (car-safe binding) binding) vars)) - (lisp--local-variables-1 vars (car (last body))))) - (`(lambda ,_) (setq sexp nil)) - (`(lambda ,args . ,body) - (lisp--local-variables-1 - (append args vars) (car (last body)))) - (`(condition-case ,_ ,e) (lisp--local-variables-1 vars e)) - (`(condition-case ,v ,_ . ,catches) - (lisp--local-variables-1 - (cons v vars) (cdr (car (last catches))))) - (`(,_ . ,_) - (lisp--local-variables-1 vars (car (last sexp)))) - (`lisp--witness--lisp (or vars '(nil))) - (_ nil))) - (setq sexp (ignore-errors (butlast sexp))))) - res)) - -(defun lisp--local-variables () - "Return a list of locally let-bound variables at point." - (save-excursion - (skip-syntax-backward "w_") - (let* ((ppss (syntax-ppss)) - (txt (buffer-substring-no-properties (or (car (nth 9 ppss)) (point)) - (or (nth 8 ppss) (point)))) - (closer ())) - (dolist (p (nth 9 ppss)) - (push (cdr (syntax-after p)) closer)) - (setq closer (apply #'string closer)) - (let* ((sexp (car (read-from-string - (concat txt "lisp--witness--lisp" closer)))) - (macroexpand-advice (lambda (expander form &rest args) - (condition-case nil - (apply expander form args) - (error form)))) - (sexp - (unwind-protect - (progn - (advice-add 'macroexpand :around macroexpand-advice) - (macroexpand-all sexp)) - (advice-remove 'macroexpand macroexpand-advice))) - (vars (lisp--local-variables-1 nil sexp))) - (delq nil - (mapcar (lambda (var) - (and (symbolp var) - (not (string-match (symbol-name var) "\\`[&_]")) - ;; Eliminate uninterned vars. - (intern-soft var) - var)) - vars)))))) - -(defvar lisp--local-variables-completion-table - ;; Use `defvar' rather than `defconst' since defconst would purecopy this - ;; value, which would doubly fail: it would fail because purecopy can't - ;; handle the recursive bytecode object, and it would fail because it would - ;; move `lastpos' and `lastvars' to pure space where they'd be immutable! - (let ((lastpos nil) (lastvars nil)) - (letrec ((hookfun (lambda () - (setq lastpos nil) - (remove-hook 'post-command-hook hookfun)))) - (completion-table-dynamic - (lambda (_string) - (save-excursion - (skip-syntax-backward "_w") - (let ((newpos (cons (point) (current-buffer)))) - (unless (equal lastpos newpos) - (add-hook 'post-command-hook hookfun) - (setq lastpos newpos) - (setq lastvars - (mapcar #'symbol-name (lisp--local-variables)))))) - lastvars))))) - -(defun lisp-completion-at-point (&optional _predicate) - "Function used for `completion-at-point-functions' in `emacs-lisp-mode'." - (with-syntax-table emacs-lisp-mode-syntax-table - (let* ((pos (point)) - (beg (condition-case nil - (save-excursion - (backward-sexp 1) - (skip-syntax-forward "'") - (point)) - (scan-error pos))) - (end - (unless (or (eq beg (point-max)) - (member (char-syntax (char-after beg)) '(?\" ?\( ?\)))) - (condition-case nil - (save-excursion - (goto-char beg) - (forward-sexp 1) - (when (>= (point) pos) - (point))) - (scan-error pos)))) - (funpos (eq (char-before beg) ?\()) ;t if in function position. - (table-etc - (if (not funpos) - ;; FIXME: We could look at the first element of the list and - ;; use it to provide a more specific completion table in some - ;; cases. E.g. filter out keywords that are not understood by - ;; the macro/function being called. - (list nil (completion-table-in-turn - lisp--local-variables-completion-table - obarray) ;Could be anything. - :annotation-function - (lambda (str) (if (fboundp (intern-soft str)) " <f>"))) - ;; Looks like a funcall position. Let's double check. - (save-excursion - (goto-char (1- beg)) - (let ((parent - (condition-case nil - (progn (up-list -1) (forward-char 1) - (let ((c (char-after))) - (if (eq c ?\() ?\( - (if (memq (char-syntax c) '(?w ?_)) - (read (current-buffer)))))) - (error nil)))) - (pcase parent - ;; FIXME: Rather than hardcode special cases here, - ;; we should use something like a symbol-property. - (`declare - (list t (mapcar (lambda (x) (symbol-name (car x))) - (delete-dups - (append - macro-declarations-alist - defun-declarations-alist))))) - ((and (or `condition-case `condition-case-unless-debug) - (guard (save-excursion - (ignore-errors - (forward-sexp 2) - (< (point) beg))))) - (list t obarray - :predicate (lambda (sym) (get sym 'error-conditions)))) - (_ (list nil obarray #'fboundp)))))))) - (when end - (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 e8b513fcd3e..8983454d318 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 -*- +;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*- ;; -;; Copyright (C) 2004-2013 Free Software Foundation, Inc. +;; Copyright (C) 2004-2015 Free Software Foundation, Inc. ;; ;; Author: Miles Bader <miles@gnu.org> ;; Keywords: lisp, compiler, macros @@ -25,7 +25,6 @@ ;; This file contains macro-expansions functions that are not defined in ;; the Lisp core, namely `macroexpand-all', which expands all macros in ;; a form, not just a top-level one. -;; ;;; Code: @@ -97,7 +96,8 @@ each clause." (defun macroexp--compiler-macro (handler form) (condition-case err (apply handler form (cdr form)) - (error (message "Compiler-macro error for %S: %S" (car form) err) + (error + (message "Compiler-macro error for %S: %S" (car form) err) form))) (defun macroexp--funcall-if-compiled (_form) @@ -119,36 +119,89 @@ and also to avoid outputting the warning during normal execution." (member '(declare-function . byte-compile-macroexpand-declare-function) macroexpand-all-environment)) +(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) -(defun macroexp--warn-and-return (msg form) +(defun macroexp--warn-and-return (msg form &optional compile-only) (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) (cond ((null msg) form) ((macroexp--compiling-p) - `(progn - (macroexp--funcall-if-compiled ',when-compiled) - ,form)) + (if (gethash form macroexp--warned) + ;; Already wrapped this exp with a warning: avoid inf-looping + ;; where we keep adding the same warning onto `form' because + ;; macroexpand-all gets right back to macroexpanding `form'. + form + (puthash form form macroexp--warned) + `(progn + (macroexp--funcall-if-compiled ',when-compiled) + ,form))) (t - (message "%s%s" (if (stringp load-file-name) - (concat (file-relative-name load-file-name) ": ") - "") - msg) + (unless compile-only + (message "%s%s" (if (stringp load-file-name) + (concat (file-relative-name load-file-name) ": ") + "") + msg)) form)))) (defun macroexp--obsolete-warning (fun obsolescence-data type) (let ((instead (car obsolescence-data)) (asof (nth 2 obsolescence-data))) - (format "`%s' is an obsolete %s%s%s" fun type - (if asof (concat " (as of " asof ")") "") - (cond ((stringp instead) (concat "; " instead)) - (instead (format "; use `%s' instead." instead)) - (t "."))))) + (format-message + "`%s' is an obsolete %s%s%s" fun type + (if asof (concat " (as of " asof ")") "") + (cond ((stringp instead) (concat "; " (substitute-command-keys instead))) + (instead (format-message "; use `%s' instead." instead)) + (t "."))))) + +(defun macroexpand-1 (form &optional environment) + "Perform (at most) one step of macroexpansion." + (cond + ((consp form) + (let* ((head (car form)) + (env-expander (assq head environment))) + (if env-expander + (if (cdr env-expander) + (apply (cdr env-expander) (cdr form)) + form) + (if (not (and (symbolp head) (fboundp head))) + form + (let ((def (autoload-do-load (symbol-function head) head 'macro))) + (cond + ;; Follow alias, but only for macros, otherwise we may end up + ;; skipping an important compiler-macro (e.g. cl--block-wrapper). + ((and (symbolp def) (macrop def)) (cons def (cdr form))) + ((not (consp def)) form) + (t + (if (eq 'macro (car def)) + (apply (cdr def) (cdr form)) + form)))))))) + (t form))) + +(defun macroexp-macroexpand (form env) + "Like `macroexpand' but checking obsolescence." + (let ((new-form + (macroexpand form env))) + (if (and (not (eq form new-form)) ;It was a macro call. + (car-safe form) + (symbolp (car form)) + (get (car form) 'byte-obsolete-info) + (or (not (fboundp 'byte-compile-warning-enabled-p)) + (byte-compile-warning-enabled-p 'obsolete))) + (let* ((fun (car form)) + (obsolete (get fun 'byte-obsolete-info))) + (macroexp--warn-and-return + (macroexp--obsolete-warning + fun obsolete + (if (symbolp (symbol-function fun)) + "alias" "macro")) + new-form)) + new-form))) (defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. Assumes the caller has bound `macroexpand-all-environment'." - (if (and (listp form) (eq (car form) 'backquote-list*)) + (if (eq (car-safe form) 'backquote-list*) ;; Special-case `backquote-list*', as it is normally a macro that ;; generates exceedingly deep expansions from relatively shallow input ;; forms. We just process it `in reverse' -- first we expand all the @@ -156,24 +209,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexpand (macroexp--all-forms form 1) macroexpand-all-environment) ;; Normal form; get its expansion, and then expand arguments. - (let ((new-form - (macroexpand form macroexpand-all-environment))) - (setq form - (if (and (not (eq form new-form)) ;It was a macro call. - (car-safe form) - (symbolp (car form)) - (get (car form) 'byte-obsolete-info) - (or (not (fboundp 'byte-compile-warning-enabled-p)) - (byte-compile-warning-enabled-p 'obsolete))) - (let* ((fun (car form)) - (obsolete (get fun 'byte-obsolete-info))) - (macroexp--warn-and-return - (macroexp--obsolete-warning - fun obsolete - (if (symbolp (symbol-function fun)) - "alias" "macro")) - new-form)) - new-form))) + (setq form (macroexp-macroexpand form macroexpand-all-environment)) (pcase form (`(cond . ,clauses) (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) @@ -181,30 +217,30 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp--cons 'condition-case (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) form)) (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2)) (`(function ,(and f `(lambda . ,_))) (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form)) + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form)) (`(,(or `function `quote) . ,_) form) (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare)) (macroexp--cons fun - (macroexp--cons (macroexp--all-clauses bindings 1) - (macroexp--all-forms body) - (cdr form)) - form)) + (macroexp--cons (macroexp--all-clauses bindings 1) + (macroexp--all-forms body) + (cdr form)) + form)) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form)) + (macroexp--all-forms args) + form)) ;; The following few cases are for normal function calls that ;; are known to funcall one of their arguments. The byte ;; compiler has traditionally handled these functions specially @@ -225,6 +261,10 @@ Assumes the caller has bound `macroexpand-all-environment'." (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) (macroexp--expand-all `(,fun ,arg1 ,f . ,args)))) + (`(funcall (,(or 'quote 'function) ,(and f (pred symbolp)) . ,_) . ,args) + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro. + (macroexp--expand-all `(,f . ,args))) (`(,func . ,_) ;; Macro expand compiler macros. This cannot be delayed to ;; byte-optimize-form because the output of the compiler-macro can @@ -238,7 +278,7 @@ Assumes the caller has bound `macroexpand-all-environment'." ;; If the handler is not loaded yet, try (auto)loading the ;; function itself, which may in turn load the handler. (unless (functionp handler) - (ignore-errors + (with-demoted-errors "macroexp--expand-all: %S" (autoload-do-load (indirect-function func) func))) (let ((newform (macroexp--compiler-macro handler form))) (if (eq form newform) @@ -253,7 +293,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp--expand-all newform))) (macroexp--expand-all newform)))))) - (t form)))) + (_ form)))) ;;;###autoload (defun macroexpand-all (form &optional environment) @@ -266,13 +306,25 @@ definitions to shadow the loaded ones for use in file byte-compilation." ;;; Handy functions to use in macros. +(defun macroexp-parse-body (body) + "Parse a function BODY into (DECLARATIONS . EXPS)." + (let ((decls ())) + (while (and (cdr body) + (let ((e (car body))) + (or (stringp e) + (memq (car-safe e) + '(:documentation declare interactive cl-declare))))) + (push (pop body) decls)) + (cons (nreverse decls) body))) + (defun macroexp-progn (exps) "Return an expression equivalent to `(progn ,@EXPS)." (if (cdr exps) `(progn ,@exps) (car exps))) (defun macroexp-unprogn (exp) - "Turn EXP into a list of expressions to execute in sequence." - (if (eq (car-safe exp) 'progn) (cdr exp) (list exp))) + "Turn EXP into a list of expressions to execute in sequence. +Never returns an empty list." + (if (eq (car-safe exp) 'progn) (or (cdr exp) '(nil)) (list exp))) (defun macroexp-let* (bindings exp) "Return an expression equivalent to `(let* ,bindings ,exp)." @@ -282,40 +334,83 @@ definitions to shadow the loaded ones for use in file byte-compilation." (t `(let* ,bindings ,exp)))) (defun macroexp-if (test then else) - "Return an expression equivalent to `(if ,test ,then ,else)." + "Return an expression equivalent to `(if ,TEST ,THEN ,ELSE)." (cond ((eq (car-safe else) 'if) - (if (equal test (nth 1 else)) - ;; Doing a test a second time: get rid of the redundancy. - `(if ,test ,then ,@(nthcdr 3 else)) - `(cond (,test ,then) - (,(nth 1 else) ,(nth 2 else)) - (t ,@(nthcdr 3 else))))) + (cond + ;; Drop this optimization: It's unsafe (it assumes that `test' is + ;; pure, or at least idempotent), and it's not used even a single + ;; time while compiling Emacs's sources. + ;;((equal test (nth 1 else)) + ;; ;; Doing a test a second time: get rid of the redundancy. + ;; (message "macroexp-if: sharing 'test' %S" test) + ;; `(if ,test ,then ,@(nthcdr 3 else))) + ((equal then (nth 2 else)) + ;; (message "macroexp-if: sharing 'then' %S" then) + `(if (or ,test ,(nth 1 else)) ,then ,@(nthcdr 3 else))) + ((equal (macroexp-unprogn then) (nthcdr 3 else)) + ;; (message "macroexp-if: sharing 'then' with not %S" then) + `(if (or ,test (not ,(nth 1 else))) + ,then ,@(macroexp-unprogn (nth 2 else)))) + (t + `(cond (,test ,@(macroexp-unprogn then)) + (,(nth 1 else) ,@(macroexp-unprogn (nth 2 else))) + (t ,@(nthcdr 3 else)))))) ((eq (car-safe else) 'cond) - `(cond (,test ,then) - ;; Doing a test a second time: get rid of the redundancy, as above. - ,@(remove (assoc test else) (cdr else)))) + `(cond (,test ,@(macroexp-unprogn then)) ,@(cdr else))) ;; Invert the test if that lets us reduce the depth of the tree. ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then)) - (t `(if ,test ,then ,else)))) - -(defmacro macroexp-let2 (test var exp &rest exps) - "Bind VAR to a copyable expression that returns the value of EXP. -This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated -symbol which EXPS can find in VAR. -TEST should be the name of a predicate on EXP checking whether the `let' can -be skipped; if nil, as is usual, `macroexp-const-p' is used." + (t `(if ,test ,then ,@(macroexp-unprogn else))))) + +(defmacro macroexp-let2 (test sym exp &rest body) + "Evaluate BODY with SYM bound to an expression for EXP's value. +The intended usage is that BODY generates an expression that +will refer to EXP's value multiple times, but will evaluate +EXP only once. As BODY generates that expression, it should +use SYM to stand for the value of EXP. + +If EXP is a simple, safe expression, then SYM's value is EXP itself. +Otherwise, SYM's value is a symbol which holds the value produced by +evaluating EXP. The return value incorporates the value of BODY, plus +additional code to evaluate EXP once and save the result so SYM can +refer to it. + +If BODY consists of multiple forms, they are all evaluated +but only the last one's value matters. + +TEST is a predicate to determine whether EXP qualifies as simple and +safe; if TEST is nil, only constant expressions qualify. + +Example: + (macroexp-let2 nil foo EXP + \\=`(* ,foo ,foo)) +generates an expression that evaluates EXP once, +then returns the square of that value. +You could do this with + (let ((foovar EXP)) + (* foovar foovar)) +but using `macroexp-let2' produces more efficient code in +cases where EXP is a constant." (declare (indent 3) (debug (sexp sexp form body))) (let ((bodysym (make-symbol "body")) (expsym (make-symbol "exp"))) `(let* ((,expsym ,exp) - (,var (if (funcall #',(or test #'macroexp-const-p) ,expsym) - ,expsym (make-symbol ,(symbol-name var)))) - (,bodysym ,(macroexp-progn exps))) - (if (eq ,var ,expsym) ,bodysym - (macroexp-let* (list (list ,var ,expsym)) + (,sym (if (funcall #',(or test #'macroexp-const-p) ,expsym) + ,expsym (make-symbol ,(symbol-name sym)))) + (,bodysym ,(macroexp-progn body))) + (if (eq ,sym ,expsym) ,bodysym + (macroexp-let* (list (list ,sym ,expsym)) ,bodysym))))) +(defmacro macroexp-let2* (test bindings &rest body) + "Bind each binding in BINDINGS as `macroexp-let2' does." + (declare (indent 2) (debug (sexp (&rest (sexp form)) body))) + (pcase-exhaustive bindings + (`nil (macroexp-progn body)) + (`((,var ,exp) . ,tl) + `(macroexp-let2 ,test ,var ,exp + (macroexp-let2* ,test ,tl ,@body))))) + (defun macroexp--maxsize (exp size) (cond ((< size 0) size) ((symbolp exp) (1- size)) @@ -367,6 +462,18 @@ symbol itself." "Return non-nil if EXP can be copied without extra cost." (or (symbolp exp) (macroexp-const-p exp))) +(defun macroexp-quote (v) + "Return an expression E such that `(eval E)' is V. + +E is either V or (quote V) depending on whether V evaluates to +itself or not." + (if (and (not (consp v)) + (or (keywordp v) + (not (symbolp v)) + (memq v '(nil t)))) + v + (list 'quote v))) + ;;; Load-time macro-expansion. ;; Because macro-expansion used to be more lazy, eager macro-expansion @@ -402,7 +509,9 @@ symbol itself." (defvar macroexp--pending-eager-loads nil "Stack of files currently undergoing eager macro-expansion.") -(defun internal-macroexpand-for-load (form) +(defvar macroexp--debug-eager nil) + +(defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. (cond ;; Don't repeat the same warning for every top-level element. @@ -417,15 +526,19 @@ symbol itself." (tail (member elem (cdr (member elem bt))))) (if tail (setcdr tail (list '…))) (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) - (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" - (mapconcat #'prin1-to-string (nreverse bt) " => ")) + (if macroexp--debug-eager + (debug 'eager-macroexp-cycle) + (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => "))) (push 'skip macroexp--pending-eager-loads) form)) (t (condition-case err (let ((macroexp--pending-eager-loads (cons load-file-name macroexp--pending-eager-loads))) - (macroexpand-all form)) + (if full-p + (macroexpand-all form) + (macroexpand form))) (error ;; Hopefully this shouldn't happen thanks to the cycle detection, ;; but in case it does happen, let's catch the error and give the diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 56bfe04f9ce..b8fb540d6cb 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 -*- lexical-binding:t -*- -;; Copyright (C) 1991-1995, 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 1991-1995, 2000-2015 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) @@ -44,7 +44,7 @@ Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST. LIST is a list of objects, or a function of no arguments to return the next object or nil. -If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT\). If not +If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT). If not a string, PROMPTER is a function of one arg (an object from LIST), which returns a string to be used as the prompt for that object. If the return value is not a string, it may be nil to ignore the object or non-nil to act @@ -56,7 +56,7 @@ which gets called with each object that the user answers `yes' for. If HELP is given, it is a list (OBJECT OBJECTS ACTION), where OBJECT is a string giving the singular noun for an elt of LIST; OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive -verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"\). +verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"). At the prompts, the user may enter y, Y, or SPC to act on that object; n, N, or DEL to skip that object; ! to act on all following objects; @@ -198,7 +198,8 @@ Returns the number of actions taken." (objects (if help (nth 1 help) "objects")) (action (if help (nth 2 help) "act on"))) (concat - (format "Type SPC or `y' to %s the current %s; + (format-message "\ +Type SPC or `y' to %s the current %s; DEL or `n' to skip the current %s; RET or `q' to give up on the %s (skip all remaining %s); C-g to quit (cancel the whole command); diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el new file mode 100644 index 00000000000..5ef51f12d96 --- /dev/null +++ b/lisp/emacs-lisp/map.el @@ -0,0 +1,377 @@ +;;; map.el --- Map manipulation functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Nicolas Petton <nicolas@petton.fr> +;; Keywords: convenience, map, hash-table, alist, array +;; Version: 1.0 +;; Package: map + +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; map.el provides map-manipulation functions that work on alists, +;; hash-table and arrays. All functions are prefixed with "map-". +;; +;; Functions taking a predicate or iterating over a map using a +;; function take the function as their first argument. All other +;; functions take the map as their first argument. + +;; TODO: +;; - Add support for char-tables +;; - Maybe add support for gv? +;; - See if we can integrate text-properties +;; - A macro similar to let-alist but working on any type of map could +;; be really useful + +;;; Code: + +(require 'seq) + +(pcase-defmacro map (&rest args) + "Build a `pcase' pattern matching map elements. + +The `pcase' pattern will match each element of PATTERN against +the corresponding elements of the map. + +Extra elements of the map are ignored if fewer ARGS are +given, and the match does not fail. + +ARGS can be a list of the form (KEY PAT), in which case KEY in an +unquoted form. + +ARGS can also be a list of symbols, which stands for ('SYMBOL +SYMBOL)." + `(and (pred map-p) + ,@(map--make-pcase-bindings args))) + +(defmacro map-let (keys map &rest body) + "Bind the variables in KEYS to the elements of MAP then evaluate BODY. + +KEYS can be a list of symbols, in which case each element will be +bound to the looked up value in MAP. + +KEYS can also be a list of (KEY VARNAME) pairs, in which case +KEY is an unquoted form. + +MAP can be a list, hash-table or array." + (declare (indent 2) (debug t)) + `(pcase-let ((,(map--make-pcase-patterns keys) ,map)) + ,@body)) + +(eval-when-compile + (defmacro map--dispatch (map-var &rest args) + "Evaluate one of the forms specified by ARGS based on the type of MAP. + +The following keyword types are meaningful: `:list', +`:hash-table' and `:array'. + +An error is thrown if MAP is neither a list, hash-table nor array. + +Return RESULT if non-nil or the result of evaluation of the form." + (declare (debug t) (indent 1)) + `(cond ((listp ,map-var) ,(plist-get args :list)) + ((hash-table-p ,map-var) ,(plist-get args :hash-table)) + ((arrayp ,map-var) ,(plist-get args :array)) + (t (error "Unsupported map: %s" ,map-var))))) + +(defun map-elt (map key &optional default) + "Lookup KEY in MAP and return its associated value. +If KEY is not found, return DEFAULT which defaults to nil. + +If MAP is a list, `eql' is used to lookup KEY. + +MAP can be a list, hash-table or array." + (declare + (gv-expander + (lambda (do) + (gv-letplace (mgetter msetter) `(gv-delay-error ,map) + (macroexp-let2* nil + ;; Eval them once and for all in the right order. + ((key key) (default default)) + `(if (listp ,mgetter) + ;; Special case the alist case, since it can't be handled by the + ;; map--put function. + ,(gv-get `(alist-get ,key (gv-synthetic-place + ,mgetter ,msetter) + ,default) + do) + ,(funcall do `(map-elt ,mgetter ,key ,default) + (lambda (v) `(map--put ,mgetter ,key ,v))))))))) + (map--dispatch map + :list (alist-get key map default) + :hash-table (gethash key map default) + :array (if (and (>= key 0) (< key (seq-length map))) + (seq-elt map key) + default))) + +(defmacro map-put (map key value) + "Associate KEY with VALUE in MAP and return MAP. +If KEY is already present in MAP, replace the associated value +with VALUE. + +MAP can be a list, hash-table or array." + (macroexp-let2 nil map map + `(progn + (setf (map-elt ,map ,key) ,value) + ,map))) + +(defmacro map-delete (map key) + "Delete KEY from MAP and return MAP. +No error is signaled if KEY is not a key of MAP. If MAP is an +array, store nil at the index KEY. + +MAP can be a list, hash-table or array." + (declare (debug t)) + (gv-letplace (mgetter msetter) `(gv-delay-error ,map) + (macroexp-let2 nil key key + `(if (not (listp ,mgetter)) + (map--delete ,mgetter ,key) + ;; The alist case is special, since it can't be handled by the + ;; map--delete function. + (setf (alist-get ,key (gv-synthetic-place ,mgetter ,msetter) + nil t) + nil) + ,mgetter)))) + +(defun map-nested-elt (map keys &optional default) + "Traverse MAP using KEYS and return the looked up value or DEFAULT if nil. + +Map can be a nested map composed of alists, hash-tables and arrays." + (or (seq-reduce (lambda (acc key) + (when (map-p acc) + (map-elt acc key))) + keys + map) + default)) + +(defun map-keys (map) + "Return the list of keys in MAP. + +MAP can be a list, hash-table or array." + (map-apply (lambda (key _) key) map)) + +(defun map-values (map) + "Return the list of values in MAP. + +MAP can be a list, hash-table or array." + (map-apply (lambda (_ value) value) map)) + +(defun map-pairs (map) + "Return the elements of MAP as key/value association lists. + +MAP can be a list, hash-table or array." + (map-apply #'cons map)) + +(defun map-length (map) + "Return the length of MAP. + +MAP can be a list, hash-table or array." + (length (map-keys map))) + +(defun map-copy (map) + "Return a copy of MAP. + +MAP can be a list, hash-table or array." + (map--dispatch map + :list (seq-copy map) + :hash-table (copy-hash-table map) + :array (seq-copy map))) + +(defun map-apply (function map) + "Apply FUNCTION to each element of MAP and return the result as a list. +FUNCTION is called with two arguments, the key and the value. + +MAP can be a list, hash-table or array." + (funcall (map--dispatch map + :list #'map--apply-alist + :hash-table #'map--apply-hash-table + :array #'map--apply-array) + function + map)) + +(defun map-keys-apply (function map) + "Return the result of applying FUNCTION to each key of MAP. + +MAP can be a list, hash-table or array." + (map-apply (lambda (key _) + (funcall function key)) + map)) + +(defun map-values-apply (function map) + "Return the result of applying FUNCTION to each value of MAP. + +MAP can be a list, hash-table or array." + (map-apply (lambda (_ val) + (funcall function val)) + map)) + +(defun map-filter (pred map) + "Return an alist of key/val pairs for which (PRED key val) is non-nil in MAP. + +MAP can be a list, hash-table or array." + (delq nil (map-apply (lambda (key val) + (if (funcall pred key val) + (cons key val) + nil)) + map))) + +(defun map-remove (pred map) + "Return an alist of the key/val pairs for which (PRED key val) is nil in MAP. + +MAP can be a list, hash-table or array." + (map-filter (lambda (key val) (not (funcall pred key val))) + map)) + +(defun map-p (map) + "Return non-nil if MAP is a map (list, hash-table or array)." + (or (listp map) + (hash-table-p map) + (arrayp map))) + +(defun map-empty-p (map) + "Return non-nil if MAP is empty. + +MAP can be a list, hash-table or array." + (map--dispatch map + :list (null map) + :array (seq-empty-p map) + :hash-table (zerop (hash-table-count map)))) + +(defun map-contains-key (map key &optional testfn) + "Return non-nil if MAP contain KEY, nil otherwise. +Equality is defined by TESTFN if non-nil or by `equal' if nil. + +MAP can be a list, hash-table or array." + (seq-contains (map-keys map) key testfn)) + +(defun map-some (pred map) + "Return a non-nil if (PRED key val) is non-nil for any key/value pair in MAP. + +MAP can be a list, hash-table or array." + (catch 'map--break + (map-apply (lambda (key value) + (let ((result (funcall pred key value))) + (when result + (throw 'map--break result)))) + map) + nil)) + +(defun map-every-p (pred map) + "Return non-nil if (PRED key val) is non-nil for all elements of the map MAP. + +MAP can be a list, hash-table or array." + (catch 'map--break + (map-apply (lambda (key value) + (or (funcall pred key value) + (throw 'map--break nil))) + map) + t)) + +(defun map-merge (type &rest maps) + "Merge into a map of type TYPE all the key/value pairs in MAPS. + +MAP can be a list, hash-table or array." + (let (result) + (while maps + (map-apply (lambda (key value) + (setf (map-elt result key) value)) + (pop maps))) + (map-into result type))) + +(defun map-into (map type) + "Convert the map MAP into a map of type TYPE. + +TYPE can be one of the following symbols: list or hash-table. +MAP can be a list, hash-table or array." + (pcase type + (`list (map-pairs map)) + (`hash-table (map--into-hash-table map)) + (_ (error "Not a map type name: %S" type)))) + +(defun map--put (map key v) + (map--dispatch map + :list (let ((p (assoc key map))) + (if p (setcdr p v) + (error "No place to change the mapping for %S" key))) + :hash-table (puthash key v map) + :array (aset map key v))) + +(defun map--apply-alist (function map) + "Private function used to apply FUNCTION over MAP, MAP being an alist." + (seq-map (lambda (pair) + (funcall function + (car pair) + (cdr pair))) + map)) + +(defun map--delete (map key) + (map--dispatch map + :list (error "No place to remove the mapping for %S" key) + :hash-table (remhash key map) + :array (and (>= key 0) + (<= key (seq-length map)) + (aset map key nil))) + map) + +(defun map--apply-hash-table (function map) + "Private function used to apply FUNCTION over MAP, MAP being a hash-table." + (let (result) + (maphash (lambda (key value) + (push (funcall function key value) result)) + map) + (nreverse result))) + +(defun map--apply-array (function map) + "Private function used to apply FUNCTION over MAP, MAP being an array." + (let ((index 0)) + (seq-map (lambda (elt) + (prog1 + (funcall function index elt) + (setq index (1+ index)))) + map))) + +(defun map--into-hash-table (map) + "Convert MAP into a hash-table." + (let ((ht (make-hash-table :size (map-length map) + :test 'equal))) + (map-apply (lambda (key value) + (setf (map-elt ht key) value)) + map) + ht)) + +(defun map--make-pcase-bindings (args) + "Return a list of pcase bindings from ARGS to the elements of a map." + (seq-map (lambda (elt) + (if (consp elt) + `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt)) + `(app (pcase--flip map-elt ',elt) ,elt))) + args)) + +(defun map--make-pcase-patterns (args) + "Return a list of `(map ...)' pcase patterns built from ARGS." + (cons 'map + (seq-map (lambda (elt) + (if (and (consp elt) (eq 'map (car elt))) + (map--make-pcase-patterns elt) + elt)) + args))) + +(provide 'map) +;;; map.el ends here diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 576e72088e9..2cd34e12810 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-2015 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions, lisp, tools @@ -67,14 +67,26 @@ 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." - (let ((flist (indirect-function function)) - (docstring nil)) +(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)) + (docfun nil) + (docstring nil)) (if (eq 'macro (car-safe flist)) (setq flist (cdr flist))) (while (advice--p flist) (let ((bytecode (aref flist 1)) + (doc (aref flist 4)) (where nil)) + ;; Hack attack! For advices installed before calling + ;; Snarf-documentation, the integer offset into the DOC file will not + ;; be installed in the "core unadvised function" but in the advice + ;; object instead! So here we try to undo the damage. + (if (integerp doc) (setq docfun flist)) (dolist (elem advice--where-alist) (if (eq bytecode (cadr elem)) (setq where (car elem)))) (setq docstring @@ -83,7 +95,7 @@ Each element has the form (WHERE BYTECODE STACK) where: (propertize (format "%s advice: " where) 'face 'warning) (let ((fun (advice--car flist))) - (if (symbolp fun) (format "`%S'" fun) + (if (symbolp fun) (format-message "`%S'" fun) (let* ((name (cdr (assq 'name (advice--props flist)))) (doc (documentation fun t)) (usage (help-split-fundoc doc function))) @@ -96,22 +108,16 @@ Each element has the form (WHERE BYTECODE STACK) where: "\n"))) (setq flist (advice--cdr flist))) (if docstring (setq docstring (concat docstring "\n"))) - (let* ((origdoc (unless (eq function flist) ;Avoid inf-loops. - (documentation flist t))) + (unless docfun (setq docfun flist)) + (let* ((origdoc (unless (eq function docfun) ;Avoid inf-loops. + (documentation docfun t))) (usage (help-split-fundoc origdoc function))) (setq usage (if (null usage) (let ((arglist (help-function-arglist flist))) - (format "%S" (help-make-usage function arglist))) + (help--make-usage-docstring function arglist)) (setq origdoc (cdr usage)) (car usage))) (help-add-fundoc-usage (concat docstring origdoc) usage)))) -(defvar advice--docstring - ;; Can't eval-when-compile nor use defconst because it then gets pure-copied, - ;; which drops the text-properties. - ;;(eval-when-compile - (propertize "Advised function" - 'dynamic-docstring-function #'advice--make-docstring)) ;; ) - (defun advice-eval-interactive-spec (spec) "Evaluate the interactive spec SPEC." (cond @@ -125,48 +131,65 @@ Each element has the form (WHERE BYTECODE STACK) where: ;; ((functionp spec) (funcall spec)) (t (eval spec)))) +(defun advice--interactive-form (function) + ;; Like `interactive-form' but tries to avoid autoloading functions. + (when (commandp function) + (if (not (and (symbolp function) (autoloadp (indirect-function function)))) + (interactive-form function) + `(interactive (advice-eval-interactive-spec + (cadr (interactive-form ',function))))))) + (defun advice--make-interactive-form (function main) ;; TODO: make it so that interactive spec can be a constant which ;; dynamically checks the advice--car/cdr to do its job. ;; For that, advice-eval-interactive-spec needs to be more faithful. - ;; FIXME: The calls to interactive-form below load autoloaded functions - ;; too eagerly. - (let ((fspec (cadr (interactive-form function)))) + (let* ((iff (advice--interactive-form function)) + (ifm (advice--interactive-form main)) + (fspec (cadr iff))) (when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda? (setq fspec (nth 1 fspec))) (if (functionp fspec) - `(funcall ',fspec - ',(cadr (interactive-form main))) - (cadr (or (interactive-form function) - (interactive-form main)))))) + `(funcall ',fspec ',(cadr ifm)) + (cadr (or iff ifm))))) -(defsubst advice--make-1 (byte-code stack-depth function main props) +(defun advice--make-1 (byte-code stack-depth function main props) "Build a function value that adds FUNCTION to MAIN." (let ((adv-sig (gethash main advertised-signature-table)) (advice (apply #'make-byte-code 128 byte-code - (vector #'apply function main props) stack-depth - advice--docstring - (when (or (commandp function) (commandp main)) - (list (advice--make-interactive-form - function main)))))) + (vector #'apply function main props) stack-depth nil + (and (or (commandp function) (commandp main)) + (list (advice--make-interactive-form + function main)))))) (when adv-sig (puthash advice adv-sig advertised-signature-table)) advice)) (defun advice--make (where function main props) "Build a function value that adds FUNCTION to MAIN at WHERE. WHERE is a symbol to select an entry in `advice--where-alist'." - (let ((desc (assq where advice--where-alist))) - (unless desc (error "Unknown add-function location `%S'" where)) - (advice--make-1 (nth 1 desc) (nth 2 desc) - function main props))) - -(defun advice--member-p (function name definition) + (let ((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 use-name definition) (let ((found nil)) (while (and (not found) (advice--p definition)) - (if (or (equal function (advice--car definition)) - (when name - (equal name (cdr (assq 'name (advice--props definition)))))) + (if (if (eq use-name :use-both) + (or (equal function + (cdr (assq 'name (advice--props definition)))) + (equal function (advice--car definition))) + (equal function (if use-name + (cdr (assq 'name (advice--props definition))) + (advice--car definition)))) (setq found definition) (setq definition (advice--cdr definition)))) found)) @@ -190,8 +213,8 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (lambda (first rest props) (cond ((not first) rest) ((or (equal function first) - (equal function (cdr (assq 'name props)))) - (list rest)))))) + (equal function (cdr (assq 'name props)))) + (list (advice--remove-function rest function))))))) (defvar advice--buffer-local-function-sample nil "keeps an example of the special \"run the default value\" functions. @@ -213,11 +236,16 @@ different, but `function-equal' will hopefully ignore those differences.") ;; This function acts like the t special value in buffer-local hooks. (lambda (&rest args) (apply (default-value var) args))))) +(eval-and-compile + (defun advice--normalize-place (place) + (cond ((eq 'local (car-safe place)) `(advice--buffer-local ,@(cdr place))) + ((eq 'var (car-safe place)) (nth 1 place)) + ((symbolp place) `(default-value ',place)) + (t place)))) + ;;;###autoload (defmacro add-function (where place function &optional props) ;; TODO: - ;; - provide some kind of control over ordering. E.g. debug-on-entry, ELP - ;; and tracing want to stay first. ;; - maybe let `where' specify some kind of predicate and use it ;; to implement things like mode-local or eieio-defmethod. ;; Of course, that only makes sense if the predicates of all advices can @@ -245,9 +273,14 @@ 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. -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 PLACE is a symbol, its `default-value' will be affected. +Use (local 'SYMBOL) if you want to apply FUNCTION to SYMBOL buffer-locally. +Use (var VAR) if you want to apply FUNCTION to the (lexical) VAR. If one of FUNCTION or OLDFUN is interactive, then the resulting function is also interactive. There are 3 cases: @@ -257,20 +290,18 @@ is also interactive. There are 3 cases: `advice-eval-interactive-spec') and return the list of arguments to use. - Else, use the interactive spec of FUNCTION and ignore the one of OLDFUN." (declare (debug t)) ;;(indent 2) - (cond ((eq 'local (car-safe place)) - (setq place `(advice--buffer-local ,@(cdr place)))) - ((symbolp place) - (setq place `(default-value ',place)))) - `(advice--add-function ,where (gv-ref ,place) ,function ,props)) + `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) + ,function ,props)) ;;;###autoload (defun advice--add-function (where ref function props) - (let ((a (advice--member-p function (cdr (assq 'name props)) - (gv-deref ref)))) + (let* ((name (cdr (assq 'name props))) + (a (advice--member-p (or name function) (if name t) (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)))) + (advice--remove-function (gv-deref ref) + (or name (advice--car a))))) (setf (gv-deref ref) (advice--make where function (gv-deref ref) props)))) @@ -281,11 +312,7 @@ If FUNCTION was not added to PLACE, do nothing. Instead of FUNCTION being the actual function, it can also be the `name' of the piece of advice." (declare (debug t)) - (cond ((eq 'local (car-safe place)) - (setq place `(advice--buffer-local ,@(cdr place)))) - ((symbolp place) - (error "Use (default-value '%S) or (local '%S)" place place))) - (gv-letplace (getter setter) place + (gv-letplace (getter setter) (advice--normalize-place place) (macroexp-let2 nil new `(advice--remove-function ,getter ,function) `(unless (eq ,new ,getter) ,(funcall setter new))))) @@ -301,7 +328,7 @@ properties alist that was specified when it was added." "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)) + (advice--member-p advice :use-both function-def)) ;;;; Specific application of add-function to `symbol-function' for advice. @@ -360,7 +387,6 @@ of the piece of advice." (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) @@ -379,15 +405,15 @@ is defined as a macro, alias, command, ..." ;; Reasons to delay installation of the advice: ;; - If the function is not yet defined, installing ;; the advice would affect `fboundp'ness. - ;; - If it's an autoloaded command, - ;; advice--make-interactive-form would end up - ;; loading the command eagerly. + ;; - the symbol-function slot of an autoloaded + ;; function is not itself a function value. ;; - `autoload' does nothing if the function is ;; not an autoload or undefined. ((or (not nf) (autoloadp nf)) (get symbol 'advice--pending)) (t (symbol-function symbol))) function props) + (put symbol 'function-documentation `(advice--make-docstring ',symbol)) (add-function :around (get symbol 'defalias-fset-function) #'advice--defalias-fset)) nil) @@ -407,7 +433,6 @@ of the piece of advice." (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))) @@ -416,6 +441,30 @@ of the piece of advice." (fset symbol (car (get symbol 'advice--saved-rewrite))))))) nil) +;;;###autoload +(defmacro define-advice (symbol args &rest body) + "Define an advice and add it to function named SYMBOL. +See `advice-add' and `add-function' for explanation on the +arguments. Note if NAME is nil the advice is anonymous; +otherwise it is named `SYMBOL@NAME'. + +\(fn SYMBOL (WHERE LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" + (declare (indent 2) (doc-string 3) (debug (sexp sexp body))) + (or (listp args) (signal 'wrong-type-argument (list 'listp args))) + (or (<= 2 (length args) 4) + (signal 'wrong-number-of-arguments (list 2 4 (length args)))) + (let* ((where (nth 0 args)) + (lambda-list (nth 1 args)) + (name (nth 2 args)) + (depth (nth 3 args)) + (props (and depth `((depth . ,depth)))) + (advice (cond ((null name) `(lambda ,lambda-list ,@body)) + ((or (stringp name) (symbolp name)) + (intern (format "%s@%s" symbol name))) + (t (error "Unrecognized name spec `%S'" name))))) + `(prog1 ,@(and (symbolp advice) `((defun ,advice ,lambda-list ,@body))) + (advice-add ',symbol ,where #',advice ,@(and props `(',props)))))) + (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 @@ -473,8 +522,9 @@ of the piece of advice." (while (progn (funcall get-next-frame) - (not (and (eq (nth 1 frame2) 'apply) - (eq (nth 3 frame2) inneradvice))))) + (and frame2 + (not (and (eq (nth 1 frame2) 'apply) + (eq (nth 3 frame2) inneradvice)))))) (funcall get-next-frame) (funcall get-next-frame)))) (- i origi 1)))) diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index 76d7565d64b..81d0b834722 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -1,6 +1,6 @@ ;;; package-x.el --- Package extras -;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2015 Free Software Foundation, Inc. ;; Author: Tom Tromey <tromey@redhat.com> ;; Created: 10 Mar 2007 @@ -114,18 +114,12 @@ inserted after its first occurrence in the file." (defun package--archive-contents-from-url (archive-url) "Parse archive-contents file at ARCHIVE-URL. Return the file contents, as a string, or nil if unsuccessful." - (ignore-errors - (when archive-url - (let* ((buffer (url-retrieve-synchronously - (concat archive-url "archive-contents")))) - (set-buffer buffer) - (package-handle-response) - (re-search-forward "^$" nil 'move) - (forward-char) - (delete-region (point-min) (point)) - (prog1 (package-read-from-string - (buffer-substring-no-properties (point-min) (point-max))) - (kill-buffer buffer)))))) + (when archive-url + (with-temp-buffer + (ignore-errors + (url-insert-file-contents (concat archive-url "archive-contents")) + (package-read-from-string + (buffer-substring-no-properties (point-min) (point-max))))))) (defun package--archive-contents-from-file () "Parse the archive-contents at `package-archive-upload-base'" @@ -162,6 +156,7 @@ DESCRIPTION is the text of the news item." archive-url)) (declare-function lm-commentary "lisp-mnt" (&optional file)) +(defvar tar-data-buffer) (defun package-upload-buffer-internal (pkg-desc extension &optional archive-url) "Upload a package whose contents are in the current buffer. @@ -209,15 +204,20 @@ if it exists." (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))) + ;; `package-upload-file' will error if given a directory, + ;; but we check it here as well just in case. + (when (eq 'dir file-type) + (user-error "Can't upload directory, tar it instead")) ;; 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 (package-make-ac-desc - split-version requires desc file-type))) + 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)))) @@ -248,7 +248,7 @@ if it exists." (concat (symbol-name pkg-name) "-readme.txt") package-archive-upload-base))) - (set-buffer pkg-buffer) + (set-buffer (if (eq file-type 'tar) tar-data-buffer pkg-buffer)) (write-region (point-min) (point-max) (expand-file-name (format "%s-%s.%s" pkg-name pkg-version extension) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index add73fd4bde..2962da5a917 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1,6 +1,6 @@ ;;; package.el --- Simple package system for Emacs -*- lexical-binding:t -*- -;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2015 Free Software Foundation, Inc. ;; Author: Tom Tromey <tromey@redhat.com> ;; Daniel Hackney <dan@haxney.org> @@ -113,8 +113,6 @@ ;;; ToDo: -;; - a trust mechanism, since compiling a package can run arbitrary code. -;; For example, download package signatures and check that they match. ;; - putting info dirs at the start of the info path means ;; users see a weird ordering of categories. OTOH we want to ;; override later entries. maybe emacs needs to enforce @@ -163,15 +161,20 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'epg)) ;For setf accessors. (require 'tabulated-list) +(require 'macroexp) (defgroup package nil "Manager for Emacs Lisp packages." :group 'applications :version "24.1") + +;;; Customization options ;;;###autoload (defcustom package-enable-at-startup t "Whether to activate installed packages when Emacs starts. @@ -182,7 +185,6 @@ and before `after-init-hook'. Activation is not done if Even if the value is nil, you can type \\[package-initialize] to activate the package system at any time." :type 'boolean - :group 'package :version "24.1") (defcustom package-load-list '(all) @@ -200,16 +202,8 @@ If VERSION is a string, only that version is ever loaded. If VERSION is nil, the package is not loaded (it is \"disabled\")." :type '(repeat symbol) :risky t - :group 'package :version "24.1") -(defvar Info-directory-list) -(declare-function info-initialize "info" ()) -(declare-function url-http-parse-response "url-http" ()) -(declare-function lm-header "lisp-mnt" (header)) -(declare-function lm-commentary "lisp-mnt" (&optional file)) -(defvar url-http-end-of-headers) - (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) "An alist of archives from which to fetch. The default value points to the GNU Emacs package repository. @@ -226,37 +220,72 @@ a package can run arbitrary code." :type '(alist :key-type (string :tag "Archive name") :value-type (string :tag "URL or directory name")) :risky t - :group 'package :version "24.1") -(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'. +(defcustom package-menu-hide-low-priority 'archive + "If non-nil, hide low priority packages from the packages menu. +A package is considered low priority if there's another version +of it available such that: + (a) the archive of the other package is higher priority than + this one, as per `package-archive-priorities'; + or + (b) they both have the same archive priority but the other + package has a higher version number. + +This variable has three possible values: + nil: no packages are hidden; + `archive': only criteria (a) is used; + t: both criteria are used. + +This variable has no effect if `package-menu--hide-packages' is +nil, so it can be toggled with \\<package-menu-mode-map> \\[package-menu-toggle-hiding]." + :type '(choice (const :tag "Don't hide anything" nil) + (const :tag "Hide per package-archive-priorities" + archive) + (const :tag "Hide per archive and version number" t)) + :version "25.1") + +(defcustom package-archive-priorities nil + "An alist of priorities for packages. + +Each element has the form (ARCHIVE-ID . PRIORITY). + +When installing packages, the package with the highest version +number from the archive with the highest priority is +selected. When higher versions are available from archives with +lower priorities, the user has to select those manually. + +Archives not in this list have the priority 0. + +See also `package-menu-hide-low-priority'." + :type '(alist :key-type (string :tag "Archive name") + :value-type (integer :tag "Priority (default is 0)")) + :risky t + :version "25.1") -If the archive of name ID does not contain the package SYM, no -other location will be considered, which will make the -package unavailable." +(defcustom package-pinned-packages nil + "An alist of packages that are pinned to specific archives. +This can be useful if you have multiple package archives enabled, +and want to control which archive a given package gets installed from. + +Each element of the alist has the form (PACKAGE . ARCHIVE), where: + PACKAGE is a symbol representing a package + ARCHIVE is a string representing an archive (it should be the car of +an element in `package-archives', e.g. \"gnu\"). + +Adding an entry to this variable means that only ARCHIVE will be +considered as a source for PACKAGE. If other archives provide PACKAGE, +they are ignored (for this package). If ARCHIVE does not contain PACKAGE, +the package will be unavailable." :type '(alist :key-type (symbol :tag "Package") :value-type (string :tag "Archive name")) + ;; I don't really see why this is risky... + ;; I suppose it could prevent you receiving updates for a package, + ;; via an entry (PACKAGE . NON-EXISTING). Which could be an issue + ;; if PACKAGE has a known vulnerability that is fixed in newer versions. :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.") - -;; 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 -non-empty lists of `package-desc' structures.") -(put 'package-archive-contents 'risky-local-variable t) - (defcustom package-user-dir (locate-user-emacs-file "elpa") "Directory containing the user's Emacs Lisp packages. The directory name should be absolute. @@ -264,7 +293,6 @@ Apart from this directory, Emacs also looks for system-wide packages in `package-directory-list'." :type 'directory :risky t - :group 'package :version "24.1") (defcustom package-directory-list @@ -272,8 +300,8 @@ packages in `package-directory-list'." (let (result) (dolist (f load-path) (and (stringp f) - (equal (file-name-nondirectory f) "site-lisp") - (push (expand-file-name "elpa" f) result))) + (equal (file-name-nondirectory f) "site-lisp") + (push (expand-file-name "elpa" f) result))) (nreverse result)) "List of additional directories containing Emacs Lisp packages. Each directory name should be absolute. @@ -282,9 +310,60 @@ These directories contain packages intended for system-wide; in contrast, `package-user-dir' contains packages for personal use." :type '(repeat directory) :risky t - :group 'package :version "24.1") +(defvar epg-gpg-program) + +(defcustom package-check-signature + (if (progn (require 'epg-config) (executable-find epg-gpg-program)) + 'allow-unsigned) + "Non-nil means to check package signatures when installing. +The value `allow-unsigned' means to still install a package even if +it is unsigned. + +This also applies to the \"archive-contents\" file that lists the +contents of the archive." + :type '(choice (const nil :tag "Never") + (const allow-unsigned :tag "Allow unsigned") + (const t :tag "Check always")) + :risky t + :version "24.4") + +(defcustom package-unsigned-archives nil + "List of archives where we do not check for package signatures." + :type '(repeat (string :tag "Archive name")) + :risky t + :version "24.4") + +(defcustom package-selected-packages nil + "Store here packages installed explicitly by user. +This variable is fed automatically by Emacs when installing a new package. +This variable is used by `package-autoremove' to decide +which packages are no longer needed. +You can use it to (re)install packages on other machines +by running `package-install-selected-packages'. + +To check if a package is contained in this list here, use +`package--user-selected-p', as it may populate the variable with +a sane initial value." + :type '(repeat symbol)) + +(defcustom package-menu-async t + "If non-nil, package-menu will use async operations when possible. +Currently, only the refreshing of archive contents supports +asynchronous operations. Package transactions are still done +synchronously." + :type 'boolean + :version "25.1") + + +;;; `package-desc' object definition +;; This is the struct used internally to represent packages. +;; Functions that deal with packages should generally take this object +;; as an argument. In some situations (e.g. commands that query the +;; user) it makes sense to take the package name as a symbol instead, +;; but keep in mind there could be multiple `package-desc's with the +;; same name. (defvar package--default-summary "No description available.") (cl-defstruct (package-desc @@ -296,7 +375,7 @@ contrast, `package-user-dir' contains packages for personal use." (:constructor package-desc-from-define (name-string version-string &optional summary requirements - &key kind archive &allow-other-keys + &rest rest-plist &aux (name (intern name-string)) (version (version-to-list version-string)) @@ -305,7 +384,21 @@ contrast, `package-user-dir' contains packages for personal use." (version-to-list (cadr elt)))) (if (eq 'quote (car requirements)) (nth 1 requirements) - 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) + (cadr value) + value)) + alist)))) + (setq rest-plist (cddr rest-plist))) + alist))))) "Structure containing information about an individual package. Slots: @@ -314,29 +407,71 @@ Slots: `version' Version of the package, as a version list. `summary' Short description of the package, typically taken from - the first line of the file. + 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. + 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'. + either `single' or `tar'. `archive' The name of the archive (as a string) whence this - package came. + package came. `dir' The directory where the package is installed (if installed), - `builtin' if it is built-in, or nil otherwise." + `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) + dir + extras + signed) + +(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)) ;; Pseudo fields. +(defun package-version-join (vlist) + "Return the version string corresponding to the list VLIST. +This is, approximately, the inverse of `version-to-list'. +\(Actually, it returns only one of the possible inverses, since +`version-to-list' is a many-to-one operation.)" + (if (null vlist) + "" + (let ((str-list (list "." (int-to-string (car vlist))))) + (dolist (num (cdr vlist)) + (cond + ((>= num 0) + (push (int-to-string num) str-list) + (push "." str-list)) + ((< num -4) + (error "Invalid version list `%s'" vlist)) + (t + ;; pre, or beta, or alpha + (cond ((equal "." (car str-list)) + (pop str-list)) + ((not (string-match "[0-9]+" (car str-list))) + (error "Invalid version list `%s'" vlist))) + (push (cond ((= num -1) "pre") + ((= num -2) "beta") + ((= num -3) "alpha") + ((= num -4) "snapshot")) + str-list)))) + (if (equal "." (car str-list)) + (pop str-list)) + (apply 'concat (nreverse str-list))))) + (defun package-desc-full-name (pkg-desc) (format "%s-%s" (package-desc-name pkg-desc) @@ -346,8 +481,19 @@ Slots: (pcase (package-desc-kind pkg-desc) (`single ".el") (`tar ".tar") + (`dir "") (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))) + +(defun package-desc-priority (p) + "Return the priority of the archive of package-desc object P." + (package-archive-priority (package-desc-archive p))) + ;; Package descriptor format used in finder-inf.el and package--builtins. (cl-defstruct (package--bi-desc (:constructor package-make-builtin (version summary)) @@ -356,6 +502,13 @@ Slots: reqs summary) + +;;; Installed packages +;; The following variables store information about packages present in +;; the system. The most important of these is `package-alist'. The +;; command `package-initialize' is also closely related to this +;; section, but it is left for a later section because it also affects +;; other stuff. (defvar package--builtins nil "Alist of built-in packages. The actual value is initialized by loading the library @@ -382,46 +535,44 @@ loaded and/or activated, customize `package-load-list'.") "List of the names of currently activated packages.") (put 'package-activated-list 'risky-local-variable t) -(defun package-version-join (vlist) - "Return the version string corresponding to the list VLIST. -This is, approximately, the inverse of `version-to-list'. -\(Actually, it returns only one of the possible inverses, since -`version-to-list' is a many-to-one operation.)" - (if (null vlist) - "" - (let ((str-list (list "." (int-to-string (car vlist))))) - (dolist (num (cdr vlist)) - (cond - ((>= num 0) - (push (int-to-string num) str-list) - (push "." str-list)) - ((< num -3) - (error "Invalid version list `%s'" vlist)) - (t - ;; pre, or beta, or alpha - (cond ((equal "." (car str-list)) - (pop str-list)) - ((not (string-match "[0-9]+" (car str-list))) - (error "Invalid version list `%s'" vlist))) - (push (cond ((= num -1) "pre") - ((= num -2) "beta") - ((= num -3) "alpha")) - str-list)))) - (if (equal "." (car str-list)) - (pop str-list)) - (apply 'concat (nreverse str-list))))) +;;;; Populating `package-alist'. +;; The following functions are called on each installed package by +;; `package-load-all-descriptors', which ultimately populates the +;; `package-alist' variable. +(defun package-process-define-package (exp) + (when (eq (car-safe exp) 'define-package) + (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))) (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))) + 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))) + (let ((pkg-desc (or (package-process-define-package + (read (current-buffer))) + (error "Can't find define-package in %s" 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 () @@ -436,10 +587,29 @@ 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))))))) + (unless (equal subdir "..") + (let ((pkg-dir (expand-file-name subdir dir))) + (when (file-directory-p pkg-dir) + (package-load-descriptor pkg-dir)))))))) + +(defun define-package (_name-string _version-string + &optional _docstring _requirements + &rest _extra-properties) + "Define a new package. +NAME-STRING is the name of the package, as a string. +VERSION-STRING is the version of the package, as a string. +DOCSTRING is a short description of the package, a string. +REQUIREMENTS is a list of dependencies on other packages. + Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION), + where OTHER-VERSION is a string. + +EXTRA-PROPERTIES is currently unused." + ;; FIXME: Placeholder! Should we keep it? + (error "Don't call me!")) + +;;; Package activation +;; Section for functions used by `package-activate', which see. (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'. @@ -455,50 +625,123 @@ Return the max version (as a string) if the package is held at a lower version." force)) (t (error "Invalid element in `package-load-list'"))))) -(defun package-activate-1 (pkg-desc) +(defun package-built-in-p (package &optional min-version) + "Return true if PACKAGE is built-in to Emacs. +Optional arg MIN-VERSION, if non-nil, should be a version list +specifying the minimum acceptable version." + (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))) + ((remove 0 min-version) nil) + (t + (require 'finder-inf nil t) ; For `package--builtins'. + (assq package package--builtins)))))) + +(defun package--autoloads-file-name (pkg-desc) + "Return the absolute name of the autoloads file, sans extension. +PKG-DESC is a `package-desc' object." + (expand-file-name + (format "%s-autoloads" (package-desc-name pkg-desc)) + (package-desc-dir pkg-desc))) + +(defun package--activate-autoloads-and-load-path (pkg-desc) + "Load the autoloads file and add package dir to `load-path'. +PKG-DESC is a `package-desc' object." + (let* ((old-lp load-path) + (pkg-dir (package-desc-dir pkg-desc)) + (pkg-dir-dir (file-name-as-directory pkg-dir))) + (with-demoted-errors "Error loading autoloads: %s" + (load (package--autoloads-file-name pkg-desc) 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)))) + +(defvar Info-directory-list) +(declare-function info-initialize "info" ()) + +(defun package-activate-1 (pkg-desc &optional reload) + "Activate package given by PKG-DESC, even if it was already active. +If RELOAD is non-nil, also `load' any files inside the package which +correspond to previously loaded files (those returned by +`package--list-loaded-files')." (let* ((name (package-desc-name pkg-desc)) - (pkg-dir (package-desc-dir pkg-desc))) + (pkg-dir (package-desc-dir pkg-desc))) (unless pkg-dir (error "Internal error: unable to find directory for `%s'" - (package-desc-full-name pkg-desc))) + (package-desc-full-name pkg-desc))) + (let* ((loaded-files-list (when reload + (package--list-loaded-files pkg-dir)))) + ;; Add to load path, add autoloads, and activate the package. + (package--activate-autoloads-and-load-path pkg-desc) + ;; Call `load' on all files in `pkg-dir' already present in + ;; `load-history'. This is done so that macros in these files are updated + ;; to their new definitions. If another package is being installed which + ;; depends on this new definition, not doing this update would cause + ;; compilation errors and break the installation. + (with-demoted-errors "Error in package-activate-1: %s" + (mapc (lambda (feature) (load feature nil t)) + ;; Skip autoloads file since we already evaluated it above. + (remove (file-truename (package--autoloads-file-name pkg-desc)) + loaded-files-list)))) ;; 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 (format "%s-autoloads" name) pkg-dir) nil t) (push name package-activated-list) ;; Don't return nil. t)) -(defun package-built-in-p (package &optional min-version) - "Return true if PACKAGE is built-in to Emacs. -Optional arg MIN-VERSION, if non-nil, should be a version list -specifying the minimum acceptable version." - (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. +(declare-function find-library-name "find-func" (library)) + +(defun package--list-loaded-files (dir) + "Recursively list all files in DIR which correspond to loaded features. +Returns the `file-name-sans-extension' of each file, relative to +DIR, sorted by most recently loaded last." + (let* ((history (delq nil + (mapcar (lambda (x) + (let ((f (car x))) + (and f (file-name-sans-extension f)))) + load-history))) + (dir (file-truename dir)) + ;; List all files that have already been loaded. + (list-of-conflicts + (delq + nil + (mapcar + (lambda (x) (let* ((file (file-relative-name x dir)) + ;; Previously loaded file, if any. + (previous + (ignore-errors + (file-name-sans-extension + (file-truename (find-library-name file))))) + (pos (when previous (member previous history)))) + ;; Return (RELATIVE-FILENAME . HISTORY-POSITION) + (when pos + (cons (file-name-sans-extension file) (length pos))))) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))))) + ;; Turn the list of (FILENAME . POS) back into a list of features. Files in + ;; subdirectories are returned relative to DIR (so not actually features). + (let ((default-directory (file-name-as-directory dir))) + (mapcar (lambda (x) (file-truename (car x))) + (sort list-of-conflicts + ;; Sort the files by ascending HISTORY-POSITION. + (lambda (x y) (< (cdr x) (cdr y)))))))) + +;;;; `package-activate' +;; This function activates a newer version of a package if an older +;; one was already activated. It also loads a features of this +;; package which were already loaded. (defun package-activate (package &optional force) "Activate package PACKAGE. -If FORCE is true, (re-)activate it if it's already activated." +If FORCE is true, (re-)activate it if it's already activated. +Newer versions are always activated, regardless of FORCE." (let ((pkg-descs (cdr (assq package package-alist)))) ;; Check if PACKAGE is available in `package-alist'. (while @@ -521,85 +764,23 @@ If FORCE is true, (re-)activate it if it's already activated." (fail (catch 'dep-failure ;; Activate its dependencies recursively. (dolist (req (package-desc-reqs pkg-vec)) - (unless (package-activate (car req) (cadr req)) + (unless (package-activate (car req)) (throw 'dep-failure req)))))) - (if fail - (warn "Unable to activate package `%s'. + (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 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. -DOCSTRING is a short description of the package, a string. -REQUIREMENTS is a list of dependencies on other packages. - Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION), - where OTHER-VERSION is a string. - -EXTRA-PROPERTIES is currently unused." - ;; 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) - (write-region - (concat ";;; " (file-name-nondirectory file) - " --- automatically extracted autoloads\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" - ";; no-update-autoloads: t\n" - ";; End:\n" - ";;; " (file-name-nondirectory file) - " ends here\n") - nil file)) - file) + package (car fail) (package-version-join (cadr fail))) + ;; If all goes well, activate the package itself. + (package-activate-1 pkg-vec force))))))) -(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 (format "%s-autoloads.el" name)) - ;;(ignore-name (concat name "-pkg.el")) - (generated-autoload-file (expand-file-name auto-name pkg-dir)) - (version-control 'never)) - (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))) - auto-name)) + +;;; Installation -- Local operations +;; This section contains a variety of features regarding installing a +;; package to/from disk. This includes autoload generation, +;; unpacking, compiling, as well as defining a package from the +;; current buffer. +;;;; Unpacking (defvar tar-parse-info) (declare-function tar-untar-buffer "tar-mode" ()) (declare-function tar-header-name "tar-mode" (tar-header) t) @@ -613,50 +794,41 @@ untar into a directory named DIR; otherwise, signal an error." (tar-mode) ;; Make sure everything extracts into DIR. (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/")) - (case-fold-search (memq system-type '(windows-nt ms-dos cygwin)))) + (case-fold-search (memq system-type '(windows-nt ms-dos cygwin)))) (dolist (tar-data tar-parse-info) (let ((name (expand-file-name (tar-header-name tar-data)))) - (or (string-match regexp name) - ;; Tarballs created by some utilities don't list - ;; directories with a trailing slash (Bug#13136). - (and (string-equal dir name) - (eq (tar-header-link-type tar-data) 5)) - (error "Package does not untar cleanly into directory %s/" dir))))) + (or (string-match regexp name) + ;; Tarballs created by some utilities don't list + ;; directories with a trailing slash (Bug#13136). + (and (string-equal dir name) + (eq (tar-header-link-type tar-data) 5)) + (error "Package does not untar cleanly into directory %s/" dir))))) (tar-untar-buffer)) -(defun package-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 - (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))))) - "\n") - nil - pkg-file)))) - +(defun package--alist-to-plist-args (alist) + (mapcar 'macroexp-quote + (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))) + (pkg-dir (expand-file-name dirname package-user-dir))) (pcase (package-desc-kind pkg-desc) + (`dir + (make-directory pkg-dir t) + (let ((file-list + (directory-files + default-directory 'full "\\`[^.].*\\.el\\'" 'nosort))) + (dolist (source-file file-list) + (let ((target-el-file + (expand-file-name (file-name-nondirectory source-file) pkg-dir))) + (copy-file source-file target-el-file t))) + ;; Now that the files have been installed, this package is + ;; indistinguishable from a `tar' or a `single'. Let's make + ;; things simple by ensuring we're one of them. + (setf (package-desc-kind pkg-desc) + (if (> (length file-list) 1) 'tar 'single)))) (`tar (make-directory package-user-dir t) ;; FIXME: should we delete PKG-DIR if it exists? @@ -679,23 +851,269 @@ untar into a directory named DIR; otherwise, signal an error." (package-activate name 'force) pkg-dir)) +(defun package-generate-description-file (pkg-desc pkg-file) + "Create the foo-pkg.el file for single-file packages." + (let* ((name (package-desc-name pkg-desc))) + (let ((print-level nil) + (print-quoted t) + (print-length nil)) + (write-region + (concat + ";;; -*- no-byte-compile: t -*-\n" + (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-args + (package-desc-extras pkg-desc)))) + "\n") + nil pkg-file nil 'silent)))) + +;;;; Autoload +;; 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) + (write-region + (concat ";;; " (file-name-nondirectory file) + " --- automatically extracted autoloads\n" + ";;\n" + ";;; Code:\n" + ;; `load-path' should contain only directory names + "(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))\n" + " \n;; Local Variables:\n" + ";; version-control: never\n" + ";; no-byte-compile: t\n" + ";; no-update-autoloads: t\n" + ";; End:\n" + ";;; " (file-name-nondirectory file) + " ends here\n") + nil file nil 'silent)) + file) + +(defvar generated-autoload-file) +(defvar version-control) + +(defun package-generate-autoloads (name pkg-dir) + (let* ((auto-name (format "%s-autoloads.el" name)) + ;;(ignore-name (concat name "-pkg.el")) + (generated-autoload-file (expand-file-name auto-name pkg-dir)) + ;; Silence `autoload-generate-file-autoloads'. + (noninteractive inhibit-message) + (backup-inhibited t) + (version-control 'never)) + (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))) + auto-name)) + (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))) + (let ((desc-file (expand-file-name (package--description-file pkg-dir) + pkg-dir))) (unless (file-exists-p desc-file) - (package-generate-description-file pkg-desc pkg-dir))) + (package-generate-description-file pkg-desc desc-file))) ;; FIXME: Create foo.info and dir file from foo.texi? ) +;;;; Compilation +(defvar warning-minimum-level) (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)) + (let ((warning-minimum-level :error) + (save-silently inhibit-message) + (load-path load-path)) + (package--activate-autoloads-and-load-path pkg-desc) + (byte-recompile-directory (package-desc-dir pkg-desc) 0 t))) + +;;;; Inferring package from current buffer +(defun package-read-from-string (str) + "Read a Lisp expression from STR. +Signal an error if the entire string was not used." + (let* ((read-data (read-from-string str)) + (more-left + (condition-case nil + ;; The call to `ignore' suppresses a compiler warning. + (progn (ignore (read-from-string + (substring str (cdr read-data)))) + t) + (end-of-file nil)))) + (if more-left + (error "Can't read whole string") + (car read-data)))) + +(defun package--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)) + ((and (listp dep) (null (cdr dep))) + (list (car dep) "0")) + (t dep))) + deps)))) + +(declare-function lm-header "lisp-mnt" (header)) +(declare-function lm-homepage "lisp-mnt" (&optional file)) +(declare-function lm-maintainer "lisp-mnt" (&optional file)) +(declare-function lm-authors "lisp-mnt" (&optional file)) + +(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 "Package lacks a file header")) + (let ((file-name (match-string-no-properties 1)) + (desc (match-string-no-properties 2)) + (start (line-beginning-position))) + (unless (search-forward (concat ";;; " file-name ".el ends here")) + (error "Package lacks a terminating comment")) + ;; Try to include a trailing newline. + (forward-line) + (narrow-to-region start (point)) + (require 'lisp-mnt) + ;; Use some headers we've invented to drive the process. + (let* ((requires-str (lm-header "package-requires")) + ;; 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")))) + (homepage (lm-homepage))) + (unless pkg-version + (error + "Package lacks a \"Version\" or \"Package-Version\" header")) + (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 + :maintainer (lm-maintainer) + :authors (lm-authors))))) + +(defun package--read-pkg-desc (kind) + "Read a `define-package' form in current buffer. +Return the pkg-desc, with desc-kind set to KIND." + (goto-char (point-min)) + (unwind-protect + (let* ((pkg-def-parsed (read (current-buffer))) + (pkg-desc + (when (eq (car pkg-def-parsed) 'define-package) + (apply #'package-desc-from-define + (append (cdr pkg-def-parsed)))))) + (when pkg-desc + (setf (package-desc-kind pkg-desc) kind) + pkg-desc)))) + +(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. +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) + (unwind-protect + (or (package--read-pkg-desc 'tar) + (error "Can't find define-package in %s" + (tar-header-name tar-desc))) + (kill-buffer (current-buffer)))))) + +(defun package-dir-info () + "Find package information for a directory. +The return result is a `package-desc'." + (cl-assert (derived-mode-p 'dired-mode)) + (let* ((desc-file (package--description-file default-directory))) + (if (file-readable-p desc-file) + (with-temp-buffer + (insert-file-contents desc-file) + (package--read-pkg-desc 'dir)) + (let ((files (directory-files default-directory t "\\.el\\'" t)) + info) + (while files + (with-temp-buffer + (insert-file-contents (pop files)) + ;; When we find the file with the data, + (when (setq info (ignore-errors (package-buffer-info))) + ;; stop looping, + (setq files nil) + ;; set the 'dir kind, + (setf (package-desc-kind info) 'dir)))) + ;; and return the info. + info)))) + +;;; Communicating with Archives +;; Set of low-level functions for communicating with archives and +;; signature checking. (defun package--write-file-no-coding (file-name) (let ((buffer-file-coding-system 'no-conversion)) - (write-region (point-min) (point-max) file-name))) + (write-region (point-min) (point-max) file-name nil 'silent))) + +(declare-function url-http-file-exists-p "url-http" (url)) + +(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-verify-string "epg" (context signature + &optional signed-text)) +(declare-function epg-context-result-for "epg" (context name)) +(declare-function epg-signature-status "epg" (signature) t) +(declare-function epg-signature-to-string "epg" (signature)) + +(defun package--display-verify-error (context sig-file) + (unless (equal (epg-context-error-output context) "") + (with-output-to-temp-buffer "*Error*" + (with-current-buffer standard-output + (if (epg-context-result-for context 'verify) + (insert (format "Failed to verify signature %s:\n" sig-file) + (mapconcat #'epg-signature-to-string + (epg-context-result-for context 'verify) + "\n")) + (insert (format "Error while verifying signature %s:\n" sig-file))) + (insert "\nCommand output:\n" (epg-context-error-output context)))))) (defmacro package--with-work-buffer (location file &rest body) "Run BODY in a buffer containing the contents of FILE at LOCATION. @@ -707,61 +1125,436 @@ 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 - (url-retrieve-synchronously (concat ,location ,file)) - (generate-new-buffer "*package work buffer*")))) - (prog1 - (with-current-buffer buffer - (if http - (progn (package-handle-response) - (re-search-forward "^$" nil 'move) - (forward-char) - (delete-region (point-min) (point))) - (unless (file-name-absolute-p ,location) - (error "Archive location %s is not an absolute file name" - ,location)) - (insert-file-contents (expand-file-name ,file ,location))) - ,@body) - (kill-buffer buffer)))) - -(defun package-handle-response () - "Handle the response from a `url-retrieve-synchronously' call. -Parse the HTTP response and throw if an error occurred. -The url package seems to require extra processing for this. -This should be called in a `save-excursion', in the download buffer. -It will move point to somewhere in the headers." - ;; We assume HTTP here. - (require 'url-http) - (let ((response (url-http-parse-response))) - (when (or (< response 200) (>= response 300)) - (error "Error during download request:%s" - (buffer-substring-no-properties (point) (line-end-position)))))) + `(with-temp-buffer + (if (string-match-p "\\`https?:" ,location) + (url-insert-file-contents (concat ,location ,file)) + (unless (file-name-absolute-p ,location) + (error "Archive location %s is not an absolute file name" + ,location)) + (insert-file-contents (expand-file-name ,file ,location))) + ,@body)) + +(defmacro package--with-work-buffer-async (location file async &rest body) + "Run BODY in a buffer containing the contents of FILE at LOCATION. +If ASYNC is non-nil, and if it is possible, run BODY +asynchronously. If an error is encountered and ASYNC is a +function, call it with no arguments (instead of executing BODY). +If it returns non-nil, or if it wasn't a function, propagate the +error. + +For a description of the other arguments see +`package--with-work-buffer'." + (declare (indent 3) (debug t)) + (macroexp-let2* macroexp-copyable-p + ((async-1 async) + (file-1 file) + (location-1 location)) + `(if (or (not ,async-1) + (not (string-match-p "\\`https?:" ,location-1))) + (package--with-work-buffer ,location-1 ,file-1 ,@body) + ;; This `condition-case' is to catch connection errors. + (condition-case error-signal + (url-retrieve (concat ,location-1 ,file-1) + ;; This is to catch execution errors. + (lambda (status) + (condition-case error-signal + (progn + (when-let ((er (plist-get status :error))) + (error "Error retrieving: %s %S" (concat ,location-1 ,file-1) er)) + (goto-char (point-min)) + (unless (search-forward "\n\n" nil 'noerror) + (error "Invalid url response in buffer %s" + (current-buffer))) + (delete-region (point-min) (point)) + ,@body + (kill-buffer (current-buffer))) + (error (when (if (functionp ,async-1) (funcall ,async-1) t) + (signal (car error-signal) (cdr error-signal)))))) + nil + 'silent) + (error (when (if (functionp ,async-1) (funcall ,async-1) t) + (message "Error contacting: %s" (concat ,location-1 ,file-1)) + (signal (car error-signal) (cdr error-signal)))))))) + +(defun package--check-signature-content (content string &optional sig-file) + "Check signature CONTENT against STRING. +SIG-FILE is the name of the signature file, used when signaling +errors." + (let* ((context (epg-make-context 'OpenPGP)) + (homedir (expand-file-name "gnupg" package-user-dir))) + (setf (epg-context-home-directory context) homedir) + (condition-case error + (epg-verify-string context content string) + (error (package--display-verify-error context sig-file) + (signal (car error) (cdr error)))) + (let (good-signatures had-fatal-error) + ;; The .sig file may contain multiple signatures. Success if one + ;; of the signatures is good. + (dolist (sig (epg-context-result-for context 'verify)) + (if (eq (epg-signature-status sig) 'good) + (push sig good-signatures) + ;; If package-check-signature is allow-unsigned, don't + ;; signal error when we can't verify signature because of + ;; missing public key. Other errors are still treated as + ;; fatal (bug#17625). + (unless (and (eq package-check-signature 'allow-unsigned) + (eq (epg-signature-status sig) 'no-pubkey)) + (setq had-fatal-error t)))) + (when (and (null good-signatures) had-fatal-error) + (package--display-verify-error context sig-file) + (error "Failed to verify signature %s" sig-file)) + good-signatures))) + +(defun package--check-signature (location file &optional string async callback) + "Check signature of the current buffer. +Download the signature file from LOCATION by appending \".sig\" +to FILE. +GnuPG keyring is located under \"gnupg\" in `package-user-dir'. +STRING is the string to verify, it defaults to `buffer-string'. +If ASYNC is non-nil, the download of the signature file is +done asynchronously. + +If the signature is verified and CALLBACK was provided, CALLBACK +is `funcall'ed with the list of good signatures as argument (the +list can be empty). If the signatures file is not found, +CALLBACK is called with no arguments." + (let ((sig-file (concat file ".sig")) + (string (or string (buffer-string)))) + (condition-case nil + (package--with-work-buffer-async + location sig-file (when async (or callback t)) + (let ((sig (package--check-signature-content + (buffer-string) string sig-file))) + (when callback (funcall callback sig)) + sig)) + (file-error (funcall callback))))) -(defun package-install-from-archive (pkg-desc) - "Download and install a tar package." - (let ((location (package-archive-base pkg-desc)) - (file (concat (package-desc-full-name pkg-desc) - (package-desc-suffix pkg-desc)))) - (package--with-work-buffer location file - (package-unpack pkg-desc)))) + +;;; Packages on Archives +;; The following variables store information about packages available +;; from archives. The most important of these is +;; `package-archive-contents' which is initially populated by the +;; function `package-read-all-archive-contents' from a cache on disk. +;; The `package-initialize' command is also closely related to this +;; section, but it has its own section. +(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.") + +;; 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 +non-empty lists of `package-desc' structures.") +(put 'package-archive-contents 'risky-local-variable t) + +(defvar package--compatibility-table nil + "Hash table connecting package names to their compatibility. +Each key is a symbol, the name of a package. + +The value is either nil, representing an incompatible package, or +a version list, representing the highest compatible version of +that package which is available. + +A package is considered incompatible if it requires an Emacs +version higher than the one being used. To check for package +\(in)compatibility, don't read this table directly, use +`package--incompatible-p' which also checks dependencies.") + +(defun package--build-compatibility-table () + "Build `package--compatibility-table' with `package--mapc'." + ;; Initialize the list of built-ins. + (require 'finder-inf nil t) + ;; Build compat table. + (setq package--compatibility-table (make-hash-table :test 'eq)) + (package--mapc #'package--add-to-compatibility-table)) + +(defun package--add-to-compatibility-table (pkg) + "If PKG is compatible (without dependencies), add to the compatibility table. +PKG is a package-desc object. +Only adds if its version is higher than what's already stored in +the table." + (unless (package--incompatible-p pkg 'shallow) + (let* ((name (package-desc-name pkg)) + (version (or (package-desc-version pkg) '(0))) + (table-version (gethash name package--compatibility-table))) + (when (or (not table-version) + (version-list-< table-version version)) + (puthash name version package--compatibility-table))))) + +;; 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--append-to-alist (pkg-desc alist) + "Append an entry for PKG-DESC to the start of ALIST and return it. +This entry takes the form (`package-desc-name' PKG-DESC). + +If ALIST already has an entry with this name, destructively add +PKG-DESC to the cdr of this entry instead, sorted by version +number." + (let* ((name (package-desc-name pkg-desc)) + (priority-version (package-desc-priority-version pkg-desc)) + (existing-packages (assq name alist))) + (if (not existing-packages) + (cons (list name pkg-desc) + alist) + (while (if (and (cdr existing-packages) + (version-list-< priority-version + (package-desc-priority-version + (cadr existing-packages)))) + (setq existing-packages (cdr existing-packages)) + (push pkg-desc (cdr existing-packages)) + nil)) + alist))) + +(defun package--add-to-archive-contents (package archive) + "Add the PACKAGE from the given ARCHIVE if necessary. +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))))) + (pinned-to-archive (assoc name package-pinned-packages))) + ;; Skip entirely if pinned to another archive. + (when (not (and pinned-to-archive + (not (equal (cdr pinned-to-archive) archive)))) + (setq package-archive-contents + (package--append-to-alist pkg-desc package-archive-contents))))) + +(defun package--read-archive-file (file) + "Re-read archive file FILE, if it exists. +Will return the data from the file, or nil if the file does not exist. +Will throw an error if the archive version is too new." + (let ((filename (expand-file-name file package-user-dir))) + (when (file-exists-p filename) + (with-temp-buffer + (let ((coding-system-for-read 'utf-8)) + (insert-file-contents filename)) + (let ((contents (read (current-buffer)))) + (if (> (car contents) package-archive-version) + (error "Package archive version %d is higher than %d" + (car contents) package-archive-version)) + (cdr contents)))))) + +(defun package-read-archive-contents (archive) + "Re-read archive contents for ARCHIVE. +If successful, set the variable `package-archive-contents'. +If the archive version is too new, signal an error." + ;; Version 1 of 'archive-contents' is identical to our internal + ;; representation. + (let* ((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))))) + +(defvar package--old-archive-priorities nil + "Store currently used `package-archive-priorities'. +This is the value of `package-archive-priorities' last time +`package-read-all-archive-contents' was called. It can be used +by arbitrary functions to decide whether it is necessary to call +it again.") + +(defun package-read-all-archive-contents () + "Re-read `archive-contents', if it exists. +If successful, set `package-archive-contents'." + (setq package-archive-contents nil) + (setq package--old-archive-priorities package-archive-priorities) + (dolist (archive package-archives) + (package-read-archive-contents (car archive)))) +;;;; Package Initialize +;; A bit of a milestone. This brings together some of the above +;; sections and populates all relevant lists of packages from contents +;; available on disk. (defvar package--initialized nil) -(defun package-installed-p (package &optional min-version) - "Return true if PACKAGE, of MIN-VERSION or newer, is installed. -MIN-VERSION should be a version list." - (unless package--initialized (error "package.el is not yet initialized!")) - (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))) +(defvar package--init-file-ensured nil + "Whether we know the init file has package-initialize.") + +;;;###autoload +(defun package-initialize (&optional no-activate) + "Load Emacs Lisp packages, and activate them. +The variable `package-load-list' controls which packages to load. +If optional arg NO-ACTIVATE is non-nil, don't activate packages. +If `user-init-file' does not mention `(package-initialize)', add +it to the file. +If called as part of loading `user-init-file', set +`package-enable-at-startup' to nil, to prevent accidentally +loading packages twice." + (interactive) + (setq package-alist nil) + (if (equal user-init-file load-file-name) + ;; If `package-initialize' is being called as part of loading + ;; the init file, it's obvious we don't need to ensure-init. + (setq package--init-file-ensured t + ;; And likely we don't need to run it again after init. + package-enable-at-startup nil) + (package--ensure-init-file)) + (package-load-all-descriptors) + (package-read-all-archive-contents) + (unless no-activate + (dolist (elt package-alist) + (package-activate (car elt)))) + (setq package--initialized t) + ;; This uses `package--mapc' so it must be called after + ;; `package--initialized' is t. + (package--build-compatibility-table)) + + +;;;; Populating `package-archive-contents' from archives +;; This subsection populates the variables listed above from the +;; actual archives, instead of from a local cache. +(defvar package--downloads-in-progress nil + "List of in-progress asynchronous downloads.") + +(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))) + (with-file-modes 448 + (make-directory homedir t)) + (setf (epg-context-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)))) + +(defvar package--post-download-archives-hook nil + "Hook run after the archive contents are downloaded. +Don't run this hook directly. It is meant to be run as part of +`package--update-downloads-in-progress'.") +(put 'package--post-download-archives-hook 'risky-local-variable t) + +(defun package--update-downloads-in-progress (entry) + "Remove ENTRY from `package--downloads-in-progress'. +Once it's empty, run `package--post-download-archives-hook'." + ;; Keep track of the downloading progress. + (setq package--downloads-in-progress + (remove entry package--downloads-in-progress)) + ;; If this was the last download, run the hook. + (unless package--downloads-in-progress + (package-read-all-archive-contents) + (package--build-compatibility-table) + ;; We message before running the hook, so the hook can give + ;; messages as well. + (message "Package refresh done") + (run-hooks 'package--post-download-archives-hook))) + +(defun package--download-one-archive (archive file &optional async) + "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/FILE\" in `package-user-dir'." + (package--with-work-buffer-async (cdr archive) file async + (let* ((location (cdr archive)) + (name (car archive)) + (content (buffer-string)) + (dir (expand-file-name (format "archives/%s" name) package-user-dir)) + (local-file (expand-file-name file dir))) + (when (listp (read-from-string content)) + (make-directory dir t) + (if (or (not package-check-signature) + (member archive package-unsigned-archives)) + ;; If we don't care about the signature, save the file and + ;; we're done. + (progn (write-region content nil local-file nil 'silent) + (package--update-downloads-in-progress archive)) + ;; If we care, check it (perhaps async) and *then* write the file. + (package--check-signature + location file content async + ;; This function will be called after signature checking. + (lambda (&optional good-sigs) + (unless (or good-sigs (eq package-check-signature 'allow-unsigned)) + ;; Even if the sig fails, this download is done, so + ;; remove it from the in-progress list. + (package--update-downloads-in-progress archive) + (error "Unsigned archive `%s'" name)) + ;; Write out the archives file. + (write-region content nil local-file nil 'silent) + ;; Write out good signatures into archive-contents.signed file. + (when good-sigs + (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") + nil (concat local-file ".signed") nil 'silent)) + (package--update-downloads-in-progress archive) + ;; If we got this far, either everything worked or we don't mind + ;; not signing, so tell `package--with-work-buffer-async' to not + ;; propagate errors. + nil))))))) + +(defun package--download-and-read-archives (&optional async) + "Download descriptions of all `package-archives' and read them. +This populates `package-archive-contents'. If ASYNC is non-nil, +perform the downloads asynchronously." + ;; The downloaded archive contents will be read as part of + ;; `package--update-downloads-in-progress'. + (dolist (archive package-archives) + (cl-pushnew archive package--downloads-in-progress + :test #'equal)) + (dolist (archive package-archives) + (condition-case-unless-debug nil + (package--download-one-archive + archive "archive-contents" + ;; Called if the async download fails + (when async + ;; The t at the end means to propagate connection errors. + (lambda () (package--update-downloads-in-progress archive) t))) + (error (message "Failed to download `%s' archive." + (car archive)))))) + +;;;###autoload +(defun package-refresh-contents (&optional async) + "Download descriptions of all configured ELPA packages. +For each archive configured in the variable `package-archives', +inform Emacs about the latest versions of all packages it offers, +and make them available for download. +Optional argument ASYNC specifies whether to perform the +downloads in the background." + (interactive) + (unless (file-exists-p package-user-dir) + (make-directory package-user-dir t)) + (let ((default-keyring (expand-file-name "package-keyring.gpg" + data-directory)) + (inhibit-message async)) + (when (and package-check-signature (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)))))) + (package--download-and-read-archives async)) -(defun package-compute-transaction (packages requirements) + +;;; Dependency Management +;; Calculating the full transaction necessary for an installation, +;; keeping track of which packages were installed strictly as +;; dependencies, and determining which packages cannot be removed +;; because they are dependencies. +(defun package-compute-transaction (packages requirements &optional seen) "Return a list of packages to be installed, including PACKAGES. PACKAGES should be a list of `package-desc'. @@ -773,7 +1566,9 @@ version of that package. This function recursively computes the requirements of the packages in REQUIREMENTS, and returns a list of all the packages that must be installed. Packages that are already installed are -not included in this list." +not included in this list. + +SEEN is used internally to detect infinite recursion." ;; 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: @@ -781,27 +1576,35 @@ not included in this list." ;; older bar-1.3). (dolist (elt requirements) (let* ((next-pkg (car elt)) - (next-version (cadr elt)) + (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" + (when already + (if (version-list-<= next-version (package-desc-version already)) + ;; `next-pkg' is already in `packages', but its position there + ;; means it might be installed too late: remove it from there, so + ;; we re-add it (along with its dependencies) at an earlier place + ;; below (bug#16994). + (if (memq already seen) ;Avoid inf-loop on dependency cycles. + (message "Dependency cycle going through %S" + (package-desc-full-name already)) + (setq packages (delq already packages)) + (setq already nil)) + (error "Need package `%s-%s', but only %s is being installed" next-pkg (package-version-join next-version) (package-version-join (package-desc-version already))))) - + (cond + (already nil) ((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-descs (cdr (assq next-pkg package-archive-contents))) + ;; A package is required, but not installed. It might also be + ;; blocked via `package-load-list'. + (let ((pkg-descs (cdr (assq next-pkg package-archive-contents))) (found nil) + (found-something nil) (problem nil)) (while (and pkg-descs (not found)) (let* ((pkg-desc (pop pkg-descs)) @@ -809,124 +1612,228 @@ not included in this list." (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))) + ;; pkg-descs is sorted by priority, not version, so + ;; don't error just yet. + (unless found-something + (setq found-something (package-version-join version)))) (disabled (unless problem (setq problem (if (stringp disabled) - (format "Package `%s' held at version %s, \ -but version %s required" - next-pkg disabled - (package-version-join next-version)) - (format "Required package '%s' is disabled" - next-pkg))))) + (format-message + "Package `%s' held at version %s, but version %s required" + next-pkg disabled + (package-version-join next-version)) + (format-message "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)))))))) + (unless found + (cond + (problem (error "%s" problem)) + (found-something + (error "Need package `%s-%s', but only %s is available" + next-pkg (package-version-join next-version) + found-something)) + (t (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) + (cons found seen)))))))) packages) -(defun package-read-from-string (str) - "Read a Lisp expression from STR. -Signal an error if the entire string was not used." - (let* ((read-data (read-from-string str)) - (more-left - (condition-case nil - ;; The call to `ignore' suppresses a compiler warning. - (progn (ignore (read-from-string - (substring str (cdr read-data)))) - t) - (end-of-file nil)))) - (if more-left - (error "Can't read whole string") - (car read-data)))) - -(defun package--read-archive-file (file) - "Re-read archive file FILE, if it exists. -Will return the data from the file, or nil if the file does not exist. -Will throw an error if the archive version is too new." - (let ((filename (expand-file-name file package-user-dir))) - (when (file-exists-p filename) - (with-temp-buffer - (insert-file-contents-literally filename) - (let ((contents (read (current-buffer)))) - (if (> (car contents) package-archive-version) - (error "Package archive version %d is higher than %d" - (car contents) package-archive-version)) - (cdr contents)))))) +(defun package--find-non-dependencies () + "Return a list of installed packages which are not dependencies. +Finds all packages in `package-alist' which are not dependencies +of any other packages. +Used to populate `package-selected-packages'." + (let ((dep-list + (delete-dups + (apply #'append + (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p)))) + package-alist))))) + (cl-loop for p in package-alist + for name = (car p) + unless (memq name dep-list) + collect name))) + +(defun package--save-selected-packages (&optional value) + "Set and save `package-selected-packages' to VALUE." + (when value + (setq package-selected-packages value)) + (if after-init-time + (let ((save-silently inhibit-message)) + (customize-save-variable 'package-selected-packages package-selected-packages)) + (add-hook 'after-init-hook #'package--save-selected-packages))) + +(defun package--user-selected-p (pkg) + "Return non-nil if PKG is a package was installed by the user. +PKG is a package name. +This looks into `package-selected-packages', populating it first +if it is still empty." + (unless (consp package-selected-packages) + (package--save-selected-packages (package--find-non-dependencies))) + (memq pkg package-selected-packages)) + +(defun package--get-deps (pkg &optional only) + (let* ((pkg-desc (cadr (assq pkg package-alist))) + (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc) + for name = (car p) + when (assq name package-alist) + collect name)) + (indirect-deps (unless (eq only 'direct) + (delete-dups + (cl-loop for p in direct-deps + append (package--get-deps p)))))) + (cl-case only + (direct direct-deps) + (separate (list direct-deps indirect-deps)) + (indirect indirect-deps) + (t (delete-dups (append direct-deps indirect-deps)))))) + +(defun package--removable-packages () + "Return a list of names of packages no longer needed. +These are packages which are neither contained in +`package-selected-packages' nor a dependency of one that is." + (let ((needed (cl-loop for p in package-selected-packages + if (assq p package-alist) + ;; `p' and its dependencies are needed. + append (cons p (package--get-deps p))))) + (cl-loop for p in (mapcar #'car package-alist) + unless (memq p needed) + collect p))) + +(defun package--used-elsewhere-p (pkg-desc &optional pkg-list all) + "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST. +Return the first package found in PKG-LIST of which PKG is a +dependency. If ALL is non-nil, return all such packages instead. + +When not specified, PKG-LIST defaults to `package-alist' +with PKG-DESC entry removed." + (unless (string= (package-desc-status pkg-desc) "obsolete") + (let* ((pkg (package-desc-name pkg-desc)) + (alist (or pkg-list + (remove (assq pkg package-alist) + package-alist)))) + (if all + (cl-loop for p in alist + if (assq pkg (package-desc-reqs (cadr p))) + collect (cadr p)) + (cl-loop for p in alist thereis + (and (assq pkg (package-desc-reqs (cadr p))) + (cadr p))))))) + +(defun package--sort-deps-in-alist (package only) + "Return a list of dependencies for PACKAGE sorted by dependency. +PACKAGE is included as the first element of the returned list. +ONLY is an alist associating package names to package objects. +Only these packages will be in the return value an their cdrs are +destructively set to nil in ONLY." + (let ((out)) + (dolist (dep (package-desc-reqs package)) + (when-let ((cell (assq (car dep) only)) + (dep-package (cdr-safe cell))) + (setcdr cell nil) + (setq out (append (package--sort-deps-in-alist dep-package only) + out)))) + (cons package out))) + +(defun package--sort-by-dependence (package-list) + "Return PACKAGE-LIST sorted by dependence. +That is, any element of the returned list is guaranteed to not +directly depend on any elements that come before it. + +PACKAGE-LIST is a list of package-desc objects. +Indirect dependencies are guaranteed to be returned in order only +if all the in-between dependencies are also in PACKAGE-LIST." + (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list)) + out-list) + (dolist (cell alist out-list) + ;; `package--sort-deps-in-alist' destructively changes alist, so + ;; some cells might already be empty. We check this here. + (when-let ((pkg-desc (cdr cell))) + (setcdr cell nil) + (setq out-list + (append (package--sort-deps-in-alist pkg-desc alist) + out-list)))))) -(defun package-read-all-archive-contents () - "Re-read `archive-contents', if it exists. -If successful, set `package-archive-contents'." - (setq package-archive-contents nil) - (dolist (archive package-archives) - (package-read-archive-contents (car archive)))) + +;;; Installation Functions +;; As opposed to the previous section (which listed some underlying +;; functions necessary for installation), this one contains the actual +;; functions that install packages. The package itself can be +;; installed in a variety of ways (archives, buffer, file), but +;; requirements (dependencies) are always satisfied by looking in +;; `package-archive-contents'. +(defun package-archive-base (desc) + "Return the archive containing the package NAME." + (cdr (assoc (package-desc-archive desc) package-archives))) -(defun package-read-archive-contents (archive) - "Re-read archive contents for ARCHIVE. -If successful, set the variable `package-archive-contents'. -If the archive version is too new, signal an error." - ;; Version 1 of 'archive-contents' is identical to our internal - ;; representation. - (let* ((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))))) +(defun package-install-from-archive (pkg-desc) + "Download and install a tar package." + ;; This won't happen, unless the archive is doing something wrong. + (when (eq (package-desc-kind pkg-desc) 'dir) + (error "Can't install directory package from archive")) + (let* ((location (package-archive-base pkg-desc)) + (file (concat (package-desc-full-name pkg-desc) + (package-desc-suffix pkg-desc)))) + (package--with-work-buffer location file + (if (or (not package-check-signature) + (member (package-desc-archive pkg-desc) + package-unsigned-archives)) + ;; If we don't care about the signature, unpack and we're + ;; done. + (let ((save-silently t)) + (package-unpack pkg-desc)) + ;; If we care, check it and *then* write the file. + (let ((content (buffer-string))) + (package--check-signature + location file content nil + ;; This function will be called after signature checking. + (lambda (&optional good-sigs) + (unless (or good-sigs (eq package-check-signature 'allow-unsigned)) + ;; Even if the sig fails, this download is done, so + ;; remove it from the in-progress list. + (error "Unsigned package: `%s'" + (package-desc-name pkg-desc))) + ;; Signature checked, unpack now. + (with-temp-buffer (insert content) + (let ((save-silently t)) + (package-unpack pkg-desc))) + ;; Here the package has been installed successfully, mark it as + ;; signed if appropriate. + (when good-sigs + ;; Write out good signatures into NAME-VERSION.signed file. + (write-region (mapconcat #'epg-signature-to-string good-sigs "\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. + (when-let ((pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist)))) + (setf (package-desc-signed (car pkg-descs)) t)))))))))) -;; 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)) - (:copier nil) - (:type vector)) - version reqs summary kind) +(defun package-installed-p (package &optional min-version) + "Return true if PACKAGE, of MIN-VERSION or newer, is installed. +If PACKAGE is a symbol, it is the package name and MIN-VERSION +should be a version list. -(defun package--add-to-archive-contents (package archive) - "Add the PACKAGE from the given ARCHIVE if necessary. -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)) - (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)))))) +If PACKAGE is a package-desc object, MIN-VERSION is ignored." + (unless package--initialized (error "package.el is not yet initialized!")) + (if (package-desc-p package) + (let ((dir (package-desc-dir package))) + (and (stringp dir) + (file-exists-p dir))) + (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-download-transaction (packages) "Download and install all the packages in PACKAGES. @@ -936,11 +1843,67 @@ PACKAGES are satisfied, i.e. that PACKAGES is computed using `package-compute-transaction'." (mapc #'package-install-from-archive packages)) +(defun package--ensure-init-file () + "Ensure that the user's init file has `package-initialize'. +`package-initialize' doesn't have to be called, as long as it is +present somewhere in the file, even as a comment. If it is not, +add a call to it along with some explanatory comments." + ;; Don't mess with the init-file from "emacs -Q". + (when (and (stringp user-init-file) + (not package--init-file-ensured) + (file-readable-p user-init-file) + (file-writable-p user-init-file)) + (let* ((buffer (find-buffer-visiting user-init-file)) + (contains-init + (if buffer + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (re-search-forward "(package-initialize\\_>" nil 'noerror)))) + ;; Don't visit the file if we don't have to. + (with-temp-buffer + (insert-file-contents user-init-file) + (goto-char (point-min)) + (re-search-forward "(package-initialize\\_>" nil 'noerror))))) + (unless contains-init + (with-current-buffer (or buffer + (let ((delay-mode-hooks t)) + (find-file-noselect user-init-file))) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (and (looking-at-p "[[:blank:]]*\\(;\\|$\\)") + (not (eobp))) + (forward-line 1)) + (insert + "\n" + ";; Added by Package.el. This must come before configurations of\n" + ";; installed packages. Don't delete this line. If you don't want it,\n" + ";; just comment it out by adding a semicolon to the start of the line.\n" + ";; You may delete these explanatory comments.\n" + "(package-initialize)\n") + (unless (looking-at-p "$") + (insert "\n")) + (let ((file-precious-flag t)) + (save-buffer)) + (unless buffer + (kill-buffer (current-buffer))))))))) + (setq package--init-file-ensured t)) + ;;;###autoload -(defun package-install (pkg) +(defun package-install (pkg &optional dont-select) "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." +PKG can be a package-desc or a symbol naming one of the available packages +in an archive in `package-archives'. Interactively, prompt for its name. + +If called interactively or if DONT-SELECT nil, add PKG to +`package-selected-packages'. + +If PKG is a package-desc and it is already installed, don't try +to install it but still mark it as selected." (interactive (progn ;; Initialize the package system to get the list of package @@ -951,15 +1914,28 @@ in an archive in `package-archives'. Interactively, prompt for its name." (package-refresh-contents)) (list (intern (completing-read "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)))))) + (delq nil + (mapcar (lambda (elt) + (unless (package-installed-p (car elt)) + (symbol-name (car elt)))) + package-archive-contents)) + nil t)) + nil))) + (add-hook 'post-command-hook #'package-menu--post-refresh) + (let ((name (if (package-desc-p pkg) + (package-desc-name pkg) + pkg))) + (unless (or dont-select (package--user-selected-p name)) + (package--save-selected-packages + (cons name package-selected-packages))) + (if-let ((transaction + (if (package-desc-p pkg) + (unless (package-installed-p pkg) + (package-compute-transaction (list pkg) + (package-desc-reqs pkg))) + (package-compute-transaction () (list (list pkg)))))) + (package-download-transaction transaction) + (message "`%s' is already installed" name)))) (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. @@ -968,163 +1944,199 @@ Otherwise return nil." (when str (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str) (setq str (substring str (match-end 0)))) - (condition-case nil - (if (version-to-list str) - str) - (error nil)))) - -(defun package-buffer-info () - "Return a `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")) - (let ((file-name (match-string-no-properties 1)) - (desc (match-string-no-properties 2)) - (start (line-beginning-position))) - (unless (search-forward (concat ";;; " file-name ".el ends here")) - (error "Package lacks a terminating comment")) - ;; Try to include a trailing newline. - (forward-line) - (narrow-to-region start (point)) - (require 'lisp-mnt) - ;; Use some headers we've invented to drive the process. - (let* ((requires-str (lm-header "package-requires")) - ;; 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"))))) - (unless pkg-version - (error - "Package lacks a \"Version\" or \"Package-Version\" header")) - (package-desc-from-define - file-name pkg-version desc - (if requires-str (package-read-from-string requires-str)) - :kind 'single)))) - -(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. -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)))))) + (ignore-errors + (if (version-to-list str) str)))) +(declare-function lm-homepage "lisp-mnt" (&optional file)) ;;;###autoload (defun package-install-from-buffer () "Install a package from the current buffer. -The current buffer is assumed to be a single .el or .tar file that follows the -packaging guidelines; see info node `(elisp)Packaging'. +The current buffer is assumed to be a single .el or .tar file or +a directory. These must follow the packaging guidelines (see +info node `(elisp)Packaging'). + +Specially, if current buffer is a directory, the -pkg.el +description file is not mandatory, in which case the information +is derived from the main .el file in the directory. + Downloads and installs required packages as needed." (interactive) - (let ((pkg-desc (if (derived-mode-p 'tar-mode) - (package-tar-file-info) - (package-buffer-info)))) + (let* ((pkg-desc + (cond + ((derived-mode-p 'dired-mode) + ;; This is the only way a package-desc object with a `dir' + ;; desc-kind can be created. Such packages can't be + ;; uploaded or installed from archives, they can only be + ;; installed from local buffers or directories. + (package-dir-info)) + ((derived-mode-p 'tar-mode) + (package-tar-file-info)) + (t + (package-buffer-info)))) + (name (package-desc-name pkg-desc))) ;; 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) + (unless (package--user-selected-p name) + (package--save-selected-packages + (cons name package-selected-packages))) pkg-desc)) ;;;###autoload (defun package-install-file (file) "Install a package from a file. -The file can either be a tar file or an Emacs Lisp file." +The file can either be a tar file, an Emacs Lisp file, or a +directory." (interactive "fPackage file name: ") (with-temp-buffer - (insert-file-contents-literally file) - (when (string-match "\\.tar\\'" file) (tar-mode)) + (if (file-directory-p file) + (progn + (setq default-directory file) + (dired-mode)) + (insert-file-contents-literally file) + (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) - ;; Update package-alist. - (let* ((name (package-desc-name pkg-desc))) - (delete pkg-desc (assq name package-alist))) - (message "Package `%s' deleted." (package-desc-full-name pkg-desc))))) - -(defun package-archive-base (desc) - "Return the archive containing the package NAME." - (cdr (assoc (package-desc-archive desc) package-archives))) +;;;###autoload +(defun package-install-selected-packages () + "Ensure packages in `package-selected-packages' are installed. +If some packages are not installed propose to install them." + (interactive) + ;; We don't need to populate `package-selected-packages' before + ;; using here, because the outcome is the same either way (nothing + ;; gets installed). + (if (not package-selected-packages) + (message "`package-selected-packages' is empty, nothing to install") + (cl-loop for p in package-selected-packages + unless (package-installed-p p) + collect p into lst + finally + (if lst + (when (y-or-n-p + (format "%s packages will be installed:\n%s, proceed?" + (length lst) + (mapconcat #'symbol-name lst ", "))) + (mapc #'package-install lst)) + (message "All your packages are already installed"))))) -(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 (format "archives/%s" (car archive)) - package-user-dir))) - (package--with-work-buffer (cdr archive) file - ;; Read the retrieved buffer to make sure it is valid (e.g. it - ;; may fetch a URL redirect page). - (when (listp (read buffer)) - (make-directory dir t) - (setq buffer-file-name (expand-file-name file dir)) - (let ((version-control 'never)) - (save-buffer)))))) + +;;; Package Deletion +(defun package--newest-p (pkg) + "Return t if PKG is the newest package with its name." + (equal (cadr (assq (package-desc-name pkg) package-alist)) + pkg)) + +(defun package-delete (pkg-desc &optional force nosave) + "Delete package PKG-DESC. + +Argument PKG-DESC is a full description of package as vector. +Interactively, prompt the user for the package name and version. + +When package is used elsewhere as dependency of another package, +refuse deleting it and return an error. +If prefix argument FORCE is non-nil, package will be deleted even +if it is used elsewhere. +If NOSAVE is non-nil, the package is not removed from +`package-selected-packages'." + (interactive + (progn + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (unless package--initialized + (package-initialize t)) + (let* ((package-table + (mapcar + (lambda (p) (cons (package-desc-full-name p) p)) + (delq nil + (mapcar (lambda (p) (unless (package-built-in-p p) p)) + (apply #'append (mapcar #'cdr package-alist)))))) + (package-name (completing-read "Delete package: " + (mapcar #'car package-table) + nil t))) + (list (cdr (assoc package-name package-table)) + current-prefix-arg nil)))) + (let ((dir (package-desc-dir pkg-desc)) + (name (package-desc-name pkg-desc)) + pkg-used-elsewhere-by) + ;; If the user is trying to delete this package, they definitely + ;; don't want it marked as selected, so we remove it from + ;; `package-selected-packages' even if it can't be deleted. + (when (and (null nosave) + (package--user-selected-p name) + ;; Don't deselect if this is an older version of an + ;; upgraded package. + (package--newest-p pkg-desc)) + (package--save-selected-packages (remove name package-selected-packages))) + (cond ((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))) + ((and (null force) + (setq pkg-used-elsewhere-by + (package--used-elsewhere-p pkg-desc))) + ;; Don't delete packages used as dependency elsewhere. + (error "Package `%s' is used by `%s' as dependency, not deleting" + (package-desc-full-name pkg-desc) + (package-desc-name pkg-used-elsewhere-by))) + (t + (add-hook 'post-command-hook #'package-menu--post-refresh) + (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 ((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)))))) ;;;###autoload -(defun package-refresh-contents () - "Download the ELPA archive description if needed. -This informs Emacs about the latest versions of all packages, and -makes them available for download." - (interactive) - ;; FIXME: Do it asynchronously. - (unless (file-exists-p package-user-dir) - (make-directory package-user-dir t)) - (dolist (archive package-archives) - (condition-case-unless-debug nil - (package--download-one-archive archive "archive-contents") - (error (message "Failed to download `%s' archive." - (car archive))))) - (package-read-all-archive-contents)) +(defun package-reinstall (pkg) + "Reinstall package PKG. +PKG should be either a symbol, the package name, or a package-desc +object." + (interactive (list (intern (completing-read + "Reinstall package: " + (mapcar #'symbol-name + (mapcar #'car package-alist)))))) + (package-delete + (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist))) + 'force 'nosave) + (package-install pkg 'dont-select)) ;;;###autoload -(defun package-initialize (&optional no-activate) - "Load Emacs Lisp packages, and activate them. -The variable `package-load-list' controls which packages to load. -If optional arg NO-ACTIVATE is non-nil, don't activate packages." +(defun package-autoremove () + "Remove packages that are no more needed. + +Packages that are no more needed by other packages in +`package-selected-packages' and their dependencies +will be deleted." (interactive) - (setq package-alist nil) - (package-load-all-descriptors) - (package-read-all-archive-contents) - (unless no-activate - (dolist (elt package-alist) - (package-activate (car elt)))) - (setq package--initialized t)) + ;; If `package-selected-packages' is nil, it would make no sense to + ;; try to populate it here, because then `package-autoremove' will + ;; do absolutely nothing. + (when (or package-selected-packages + (yes-or-no-p + (format-message + "`package-selected-packages' is empty! Really remove ALL packages? "))) + (let ((removable (package--removable-packages))) + (if removable + (when (y-or-n-p + (format "%s packages will be deleted:\n%s, proceed? " + (length removable) + (mapconcat #'symbol-name removable ", "))) + (mapc (lambda (p) + (package-delete (cadr (assq p package-alist)) t)) + removable)) + (message "Nothing to autoremove"))))) ;;;; Package description buffer. @@ -1133,7 +2145,8 @@ 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))) + (let* ((guess (or (function-called-at-point) + (symbol-at-point)))) (require 'finder-inf nil t) ;; Load the package list if necessary (but don't activate them). (unless package--initialized @@ -1149,15 +2162,34 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (format "Describe package (default %s): " guess) "Describe package: ") - packages nil t nil nil guess))) + packages nil t nil nil (when guess + (symbol-name 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)) + (called-interactively-p 'interactive)) (with-help-window (help-buffer) (with-current-buffer standard-output - (describe-package-1 package))))) + (describe-package-1 package))))) + +(defface package-help-section-name + '((t :inherit (bold font-lock-function-name-face))) + "Face used on section names in package description buffers." + :version "25.1") + +(defun package--print-help-section (name &rest strings) + "Print \"NAME: \", right aligned to the 13th column. +If more STRINGS are provided, insert them followed by a newline. +Otherwise no newline is inserted." + (declare (indent 1)) + (insert (make-string (max 0 (- 11 (string-width name))) ?\s) + (propertize (concat name ": ") 'font-lock-face 'package-help-section-name)) + (when strings + (apply #'insert strings) + (insert "\n"))) + +(declare-function lm-commentary "lisp-mnt" (&optional file)) (defun describe-package-1 (pkg) (require 'lisp-mnt) @@ -1171,151 +2203,231 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (name (if desc (package-desc-name desc) pkg)) (pkg-dir (if desc (package-desc-dir desc))) (reqs (if desc (package-desc-reqs desc))) + (required-by (if desc (package--used-elsewhere-p desc nil 'all))) (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"))) + (status (if desc (package-desc-status desc) "orphan")) + (incompatible-reason (package--incompatible-p desc)) + (signed (if desc (package-desc-signed desc)))) + (when (string= status "avail-obso") + (setq status "available obsolete")) + (when incompatible-reason + (setq status "incompatible")) (prin1 name) (princ " is ") (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) ": ") + (package--print-help-section "Status") (cond (built-in - (insert (propertize (capitalize status) - 'font-lock-face 'font-lock-builtin-face) + (insert (propertize (capitalize status) + 'font-lock-face 'package-status-builtin-face) ".")) - (pkg-dir - (insert (propertize (capitalize status) ;FIXME: Why comment-face? - 'font-lock-face 'font-lock-comment-face)) - (insert " in `") - ;; Todo: Add button for uninstalling. - (help-insert-xref-button (abbreviate-file-name - (file-name-as-directory pkg-dir)) - 'help-package-def pkg-dir) - (if (and (package-built-in-p name) + (pkg-dir + (insert (propertize (if (member status '("unsigned" "dependency")) + "Installed" + (capitalize status)) + 'font-lock-face 'package-status-builtin-face)) + (insert (substitute-command-keys " in `")) + (let ((dir (abbreviate-file-name + (file-name-as-directory + (if (file-in-directory-p pkg-dir package-user-dir) + (file-relative-name pkg-dir package-user-dir) + pkg-dir))))) + (help-insert-xref-button dir 'help-package-def pkg-dir)) + (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 "'."))) - (installable + (insert (substitute-command-keys + "',\n shadowing a ") + (propertize "built-in package" + 'font-lock-face 'package-status-builtin-face)) + (insert (substitute-command-keys "'"))) + (if signed + (insert ".") + (insert " (unsigned).")) + (when (and (package-desc-p desc) + (not required-by) + (member status '("unsigned" "installed"))) + (insert " ") + (package-make-button "Delete" + 'action #'package-delete-button-action + 'package-desc desc))) + (incompatible-reason + (insert (propertize "Incompatible" 'font-lock-face font-lock-warning-face) + " because it depends on ") + (if (stringp incompatible-reason) + (insert "Emacs " incompatible-reason ".") + (insert "uninstallable packages."))) + (installable (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-desc desc - 'action 'package-install-button-action))) - (t (insert (capitalize status) "."))) + (insert " from " (format "%s" archive)) + (insert " -- ") + (package-make-button + "Install" + 'action 'package-install-button-action + 'package-desc desc)) + (t (insert (capitalize status) "."))) (insert "\n") + (unless (and pkg-dir (not archive)) ; Installed pkgs don't have archive. + (package--print-help-section "Archive" + (or archive "n/a") "\n")) (and version - (insert " " - (propertize "Version" 'font-lock-face 'bold) ": " - (package-version-join version) "\n")) + (package--print-help-section "Version" + (package-version-join version))) + (when desc + (package--print-help-section "Summary" + (package-desc-summary desc))) (setq reqs (if desc (package-desc-reqs desc))) (when reqs - (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ") - (let ((first t) - name vers text) - (dolist (req reqs) - (setq name (car req) - vers (cadr req) - text (format "%s-%s" (symbol-name name) - (package-version-join vers))) - (cond (first (setq first nil)) - ((>= (+ 2 (current-column) (length text)) - (window-width)) - (insert ",\n ")) - (t (insert ", "))) - (help-insert-xref-button text 'help-package name)) - (insert "\n"))) - (insert " " (propertize "Summary" 'font-lock-face 'bold) - ": " (if desc (package-desc-summary desc)) "\n") - + (package--print-help-section "Requires") + (let ((first t)) + (dolist (req reqs) + (let* ((name (car req)) + (vers (cadr req)) + (text (format "%s-%s" (symbol-name name) + (package-version-join vers))) + (reason (if (and (listp incompatible-reason) + (assq name incompatible-reason)) + " (not available)" ""))) + (cond (first (setq first nil)) + ((>= (+ 2 (current-column) (length text) (length reason)) + (window-width)) + (insert ",\n ")) + (t (insert ", "))) + (help-insert-xref-button text 'help-package name) + (insert reason))) + (insert "\n"))) + (when required-by + (package--print-help-section "Required by") + (let ((first t)) + (dolist (pkg required-by) + (let ((text (package-desc-full-name pkg))) + (cond (first (setq first nil)) + ((>= (+ 2 (current-column) (length text)) + (window-width)) + (insert ",\n ")) + (t (insert ", "))) + (help-insert-xref-button text 'help-package + (package-desc-name pkg)))) + (insert "\n"))) + (when homepage + (package--print-help-section "Homepage") + (help-insert-xref-button homepage 'help-url homepage) + (insert "\n")) + (when keywords + (package--print-help-section "Keywords") + (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"))) + (package--print-help-section "Other versions" + (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 + 'font-lock-face 'link + 'follow-link t + 'action + (lambda (_button) + (describe-package opkg))) + from)))) + other-pkgs ", ") + "."))) (insert "\n") (if built-in - ;; For built-in packages, insert the commentary. - (let ((fn (locate-file (format "%s.el" name) load-path - load-file-rep-suffixes)) - (opoint (point))) - (insert (or (lm-commentary fn) "")) - (save-excursion - (goto-char opoint) - (when (re-search-forward "^;;; Commentary:\n" nil t) - (replace-match "")) - (while (re-search-forward "^\\(;+ ?\\)" nil t) - (replace-match "")))) + ;; For built-in packages, insert the commentary. + (let ((fn (locate-file (format "%s.el" name) load-path + load-file-rep-suffixes)) + (opoint (point))) + (insert (or (lm-commentary fn) "")) + (save-excursion + (goto-char opoint) + (when (re-search-forward "^;;; Commentary:\n" nil t) + (replace-match "")) + (while (re-search-forward "^\\(;+ ?\\)" nil t) + (replace-match "")))) (let ((readme (expand-file-name (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 desc) - (format "%s-readme.txt" name) - (setq buffer-file-name - (expand-file-name readme package-user-dir)) - (let ((version-control 'never)) - (save-buffer)) - (setq readme-string (buffer-string)) - t) - (error nil)) - (insert readme-string)) - ((file-readable-p readme) - (insert-file-contents readme) - (goto-char (point-max)))))))) + 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 + (save-excursion + (package--with-work-buffer + (package-archive-base desc) + (format "%s-readme.txt" name) + (save-excursion + (goto-char (point-max)) + (unless (bolp) + (insert ?\n))) + (write-region nil nil + (expand-file-name readme package-user-dir) + nil 'silent) + (setq readme-string (buffer-string)) + t)) + (error nil)) + (insert readme-string)) + ((file-readable-p readme) + (insert-file-contents readme) + (goto-char (point-max)))))))) (defun package-install-button-action (button) (let ((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) + (when (y-or-n-p (format-message "Install package `%s'? " + (package-desc-full-name pkg-desc))) + (package-install pkg-desc nil) + (revert-buffer nil t) + (goto-char (point-min))))) + +(defun package-delete-button-action (button) + (let ((pkg-desc (button-get button 'package-desc))) + (when (y-or-n-p (format-message "Delete package `%s'? " + (package-desc-full-name pkg-desc))) + (package-delete 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. (defvar package-menu-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap "Package"))) + (let ((map (make-sparse-keymap))) (set-keymap-parent map tabulated-list-mode-map) (define-key map "\C-m" 'package-menu-describe-package) (define-key map "u" 'package-menu-mark-unmark) @@ -1324,73 +2436,69 @@ 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) + (define-key map "H" #'package-menu-hide-package) (define-key map "?" 'package-menu-describe-package) - (define-key map [menu-bar package-menu] (cons "Package" menu-map)) - (define-key menu-map [mq] - '(menu-item "Quit" quit-window - :help "Quit package selection")) - (define-key menu-map [s1] '("--")) - (define-key menu-map [mn] - '(menu-item "Next" next-line - :help "Next Line")) - (define-key menu-map [mp] - '(menu-item "Previous" previous-line - :help "Previous Line")) - (define-key menu-map [s2] '("--")) - (define-key menu-map [mu] - '(menu-item "Unmark" package-menu-mark-unmark - :help "Clear any marks on a package and move to the next line")) - (define-key menu-map [munm] - '(menu-item "Unmark Backwards" package-menu-backup-unmark - :help "Back up one line and clear any marks on that package")) - (define-key menu-map [md] - '(menu-item "Mark for Deletion" package-menu-mark-delete - :help "Mark a package for deletion and move to the next line")) - (define-key menu-map [mi] - '(menu-item "Mark for Install" package-menu-mark-install - :help "Mark a package for installation and move to the next line")) - (define-key menu-map [mupgrades] - '(menu-item "Mark Upgradable Packages" package-menu-mark-upgrades - :help "Mark packages that have a newer version for upgrading")) - (define-key menu-map [s3] '("--")) - (define-key menu-map [mg] - '(menu-item "Update Package List" revert-buffer - :help "Update the list of packages")) - (define-key menu-map [mr] - '(menu-item "Refresh Package List" package-menu-refresh - :help "Download the ELPA archive")) - (define-key menu-map [s4] '("--")) - (define-key menu-map [mt] - '(menu-item "Mark Obsolete Packages" package-menu-mark-obsolete-for-deletion - :help "Mark all obsolete packages for deletion")) - (define-key menu-map [mx] - '(menu-item "Execute Actions" package-menu-execute - :help "Perform all the marked actions")) - (define-key menu-map [s5] '("--")) - (define-key menu-map [mh] - '(menu-item "Help" package-menu-quick-help - :help "Show short key binding help for package-menu-mode")) - (define-key menu-map [mc] - '(menu-item "View Commentary" package-menu-view-commentary - :help "Display information about this package")) + (define-key map "(" #'package-menu-toggle-hiding) map) "Local keymap for `package-menu-mode' buffers.") +(easy-menu-define package-menu-mode-menu package-menu-mode-map + "Menu for `package-menu-mode'." + `("Package" + ["Describe Package" package-menu-describe-package :help "Display information about this package"] + ["Help" package-menu-quick-help :help "Show short key binding help for package-menu-mode"] + "--" + ["Refresh Package List" package-menu-refresh + :help "Redownload the ELPA archive" + :active (not package--downloads-in-progress)] + ["Redisplay buffer" revert-buffer :help "Update the buffer with current list of packages"] + ["Execute Marked Actions" package-menu-execute :help "Perform all the marked actions"] + + "--" + ["Mark All Available Upgrades" package-menu-mark-upgrades + :help "Mark packages that have a newer version for upgrading" + :active (not package--downloads-in-progress)] + ["Mark All Obsolete for Deletion" package-menu-mark-obsolete-for-deletion :help "Mark all obsolete packages for deletion"] + ["Mark for Install" package-menu-mark-install :help "Mark a package for installation and move to the next line"] + ["Mark for Deletion" package-menu-mark-delete :help "Mark a package for deletion and move to the next line"] + ["Unmark" package-menu-mark-unmark :help "Clear any marks on a package and move to the next line"] + + "--" + ["Filter Package List" package-menu-filter :help "Filter package selection (q to go back)"] + ["Hide by Regexp" package-menu-hide-package :help "Permanently hide all packages matching a regexp"] + ["Display Older Versions" package-menu-toggle-hiding + :style toggle :selected (not package-menu--hide-packages) + :help "Display package even if a newer version is already installed"] + + "--" + ["Quit" quit-window :help "Quit package selection"] + ["Customize" (customize-group 'package)])) + (defvar package-menu--new-package-list nil "List of newly-available packages since `list-packages' was last called.") +(defvar package-menu--transaction-status nil + "Mode-line status of ongoing package transaction.") + (define-derived-mode package-menu-mode tabulated-list-mode "Package Menu" "Major mode for browsing a list of packages. Letters do not insert themselves; instead, they are commands. \\<package-menu-mode-map> \\{package-menu-mode-map}" - (setq tabulated-list-format [("Package" 18 package-menu--name-predicate) - ("Version" 12 nil) - ("Status" 10 package-menu--status-predicate) - ("Description" 0 nil)]) + (setq mode-line-process '((package--downloads-in-progress ":Loading") + (package-menu--transaction-status + package-menu--transaction-status))) + (setq tabulated-list-format + `[("Package" 18 package-menu--name-predicate) + ("Version" 13 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) @@ -1407,12 +2515,47 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (defvar package-list-unversioned nil "If non-nil include packages that don't have a version in `list-package'.") +(defvar package-list-unsigned nil + "If non-nil, mention in the list which packages were installed w/o signature.") + +(defvar package--emacs-version-list (version-to-list emacs-version) + "`emacs-version', as a list.") + +(defun package--incompatible-p (pkg &optional shallow) + "Return non-nil if PKG has no chance of being installable. +PKG is a package-desc object. + +If SHALLOW is non-nil, this only checks if PKG depends on a +higher `emacs-version' than the one being used. Otherwise, also +checks the viability of dependencies, according to +`package--compatibility-table'. + +If PKG requires an incompatible Emacs version, the return value +is this version (as a string). +If PKG requires incompatible packages, the return value is a list +of these dependencies, similar to the list returned by +`package-desc-reqs'." + (let* ((reqs (package-desc-reqs pkg)) + (version (cadr (assq 'emacs reqs)))) + (if (and version (version-list-< package--emacs-version-list version)) + (package-version-join version) + (unless shallow + (let (out) + (dolist (dep (package-desc-reqs pkg) out) + (let ((dep-name (car dep))) + (unless (eq 'emacs dep-name) + (let ((cv (gethash dep-name package--compatibility-table))) + (when (version-list-< (or cv '(0)) (or (cadr dep) '(0))) + (push dep out))))))))))) + (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))) + (version (package-desc-version pkg-desc)) + (signed (or (not package-list-unsigned) + (package-desc-signed pkg-desc)))) (cond ((eq dir 'builtin) "built-in") ((and lle (null held)) "disabled") @@ -1422,34 +2565,166 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." ((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))) "installed") + ((not (file-exists-p dir)) "deleted") + ;; Not inside `package-user-dir'. + ((not (file-in-directory-p dir package-user-dir)) "external") + ((eq pkg-desc (cadr (assq name package-alist))) + (if (not signed) "unsigned" + (if (package--user-selected-p name) + "installed" "dependency"))) (t "obsolete"))) + ((package--incompatible-p pkg-desc) "incompat") (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)) + ;; Installed obsolete packages are handled in the `dir' + ;; clause above. Here we handle available obsolete, which + ;; are displayed depending on `package-menu--hide-packages'. + ((and ins (version-list-<= version ins-v)) "avail-obso") + (t (if (memq name package-menu--new-package-list) - "new" "available")) - ((version-list-< version ins-v) "obsolete") - ((version-list-= version ins-v) "installed"))))))) + "new" "available")))))))) -(defun package-menu--refresh (&optional packages) +(defvar package-menu--hide-packages t + "Whether available obsolete packages should be hidden. +Can be toggled with \\<package-menu-mode-map> \\[package-menu-toggle-hiding]. +Installed obsolete packages are always displayed.") + +(defun package-menu-toggle-hiding () + "Toggle visibility of obsolete available packages." + (interactive) + (unless (derived-mode-p 'package-menu-mode) + (user-error "The current buffer is not a Package Menu")) + (setq package-menu--hide-packages + (not package-menu--hide-packages)) + (message "%s packages" (if package-menu--hide-packages + "Hiding obsolete or unwanted" + "Displaying all")) + (revert-buffer nil 'no-confirm)) + +(defun package--remove-hidden (pkg-list) + "Filter PKG-LIST according to `package-archive-priorities'. +PKG-LIST must be a list of package-desc objects, all with the +same name, sorted by decreasing `package-desc-priority-version'. +Return a list of packages tied for the highest priority according +to their archives." + (when pkg-list + ;; Variable toggled with `package-menu-toggle-hiding'. + (if (not package-menu--hide-packages) + pkg-list + (let ((installed (cadr (assq (package-desc-name (car pkg-list)) + package-alist)))) + (when installed + (setq pkg-list + (let ((ins-version (package-desc-version installed))) + (cl-remove-if (lambda (p) (version-list-< (package-desc-version p) + ins-version)) + pkg-list)))) + (let ((filtered-by-priority + (cond + ((not package-menu-hide-low-priority) + pkg-list) + ((eq package-menu-hide-low-priority 'archive) + (let* ((max-priority most-negative-fixnum) + (out)) + (while pkg-list + (let ((p (pop pkg-list))) + (let ((priority (package-desc-priority p))) + (if (< priority max-priority) + (setq pkg-list nil) + (push p out) + (setq max-priority priority))))) + (nreverse out))) + (pkg-list + (list (car pkg-list)))))) + (if (not installed) + filtered-by-priority + (let ((ins-version (package-desc-version installed))) + (cl-remove-if (lambda (p) (version-list-= (package-desc-version p) + ins-version)) + filtered-by-priority)))))))) + +(defcustom package-hidden-regexps nil + "List of regexps matching the name of packages to hide. +If the name of a package matches any of these regexps it is +omitted from the package menu. To toggle this, type \\[package-menu-toggle-hiding]. + +Values can be interactively added to this list by typing +\\[package-menu-hide-package] on a package" + :type '(repeat (regexp :tag "Hide packages with name matching"))) + +(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." +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) + (let ((hidden-names (mapconcat #'identity package-hidden-regexps "\\|")) + info-list) + ;; Installed packages: + (dolist (elt package-alist) + (let ((name (car elt))) + (when (or (eq packages t) (memq name packages)) + (dolist (pkg (cdr elt)) + (when (package--has-keyword-p pkg keywords) + (push pkg info-list)))))) + + ;; Built-in packages: + (dolist (elt package--builtins) + (let ((pkg (package--from-builtin elt)) + (name (car elt))) + (when (not (eq name 'emacs)) ; Hide the `emacs' package. + (when (and (package--has-keyword-p pkg keywords) + (or package-list-unversioned + (package--bi-desc-version (cdr elt))) + (or (eq packages t) (memq name packages))) + (push pkg info-list))))) + + ;; Available and disabled packages: + (unless (equal package--old-archive-priorities package-archive-priorities) + (package-read-all-archive-contents)) + (dolist (elt package-archive-contents) + (let ((name (car elt))) + ;; To be displayed it must be in PACKAGES; + (when (and (or (eq packages t) (memq name packages)) + ;; and we must either not be hiding anything, + (or (not package-menu--hide-packages) + (not package-hidden-regexps) + ;; or just not hiding this specific package. + (not (string-match hidden-names (symbol-name name))))) + ;; Hide available-obsolete or low-priority packages. + (dolist (pkg (package--remove-hidden (cdr elt))) + (when (package--has-keyword-p pkg keywords) + (push pkg info-list)))))) + + ;; Print the result. + (setq tabulated-list-entries + (mapcar #'package-menu--print-info-simple info-list)))) + +(defun package-all-keywords () + "Collect all package keywords" + (let ((key-list)) + (package--mapc (lambda (desc) + (setq key-list (append (package-desc--keywords desc) + key-list)))) + key-list)) + +(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)) - (dolist (pkg (cdr elt)) - (package--push pkg (package-desc-status pkg) info-list)))) + (mapc function (cdr elt)))) ;; Built-in packages: (dolist (elt package--builtins) @@ -1457,8 +2732,8 @@ PACKAGES should be nil or t, which means to display all known packages." (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))) - (package--push (package--from-builtin elt) "built-in" info-list))) + (or (eq packages t) (memq name packages))) + (funcall function (package--from-builtin elt)))) ;; Available and disabled packages: (dolist (elt package-archive-contents) @@ -1468,46 +2743,157 @@ PACKAGES should be nil or t, which means to display all known packages." ;; Hide obsolete packages. (unless (package-installed-p (package-desc-name pkg) (package-desc-version pkg)) - (package--push pkg (package-desc-status pkg) info-list))))) - - ;; Print the result. - (setq tabulated-list-entries - (mapcar #'package-menu--print-info info-list)))) + (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) + (while (and (not found) keywords) + (let ((k (pop keywords))) + (setq found + (or (string= k (concat "arc:" (package-desc-archive desc))) + (string= k (concat "status:" (package-desc-status desc))) + (member k desc-keywords))))) + found) + t)) -(defun package-menu--generate (remember-pos packages) +(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." - (package-menu--refresh 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 (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) - (_ 'font-lock-warning-face)))) ; obsolete. - (list pkg-desc - (vector (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) - (propertize (package-desc-summary pkg-desc) - 'font-lock-face face))))) + (package-menu--print-info-simple (car pkg))) +(make-obsolete 'package-menu--print-info + 'package-menu--print-info-simple "25.1") + + +;;; Package menu faces +(defface package-name + '((t :inherit link)) + "Face used on package names in the package menu." + :version "25.1") + +(defface package-description + '((t :inherit default)) + "Face used on package description summaries in the package menu." + :version "25.1") + +(defface package-status-built-in + '((t :inherit font-lock-builtin-face)) + "Face used on the status and version of built-in packages." + :version "25.1") + +(defface package-status-external + '((t :inherit package-status-builtin-face)) + "Face used on the status and version of external packages." + :version "25.1") + +(defface package-status-available + '((t :inherit default)) + "Face used on the status and version of available packages." + :version "25.1") + +(defface package-status-new + '((t :inherit (bold package-status-available))) + "Face used on the status and version of new packages." + :version "25.1") + +(defface package-status-held + '((t :inherit font-lock-constant-face)) + "Face used on the status and version of held packages." + :version "25.1") + +(defface package-status-disabled + '((t :inherit font-lock-warning-face)) + "Face used on the status and version of disabled packages." + :version "25.1") + +(defface package-status-installed + '((t :inherit font-lock-comment-face)) + "Face used on the status and version of installed packages." + :version "25.1") + +(defface package-status-dependency + '((t :inherit package-status-installed)) + "Face used on the status and version of dependency packages." + :version "25.1") + +(defface package-status-unsigned + '((t :inherit font-lock-warning-face)) + "Face used on the status and version of unsigned packages." + :version "25.1") + +(defface package-status-incompat + '((t :inherit font-lock-comment-face)) + "Face used on the status and version of incompat packages." + :version "25.1") + +(defface package-status-avail-obso + '((t :inherit package-status-incompat)) + "Face used on the status and version of avail-obso packages." + :version "25.1") + + +;;; Package menu printing +(defun package-menu--print-info-simple (pkg) + "Return a package entry suitable for `tabulated-list-entries'. +PKG is a package-desc object. +Return (PKG-DESC [NAME VERSION STATUS DOC])." + (let* ((status (package-desc-status pkg)) + (face (pcase status + (`"built-in" 'package-status-built-in) + (`"external" 'package-status-external) + (`"available" 'package-status-available) + (`"avail-obso" 'package-status-avail-obso) + (`"new" 'package-status-new) + (`"held" 'package-status-held) + (`"disabled" 'package-status-disabled) + (`"installed" 'package-status-installed) + (`"dependency" 'package-status-dependency) + (`"unsigned" 'package-status-unsigned) + (`"incompat" 'package-status-incompat) + (_ 'font-lock-warning-face)))) ; obsolete. + (list pkg + `[(,(symbol-name (package-desc-name pkg)) + face package-name + font-lock-face package-name + follow-link t + package-desc ,pkg + action package-menu-describe-package) + ,(propertize (package-version-join + (package-desc-version pkg)) + 'font-lock-face face) + ,(propertize status 'font-lock-face face) + ,@(if (cdr package-archives) + (list (propertize (or (package-desc-archive pkg) "") + 'font-lock-face face))) + ,(propertize (package-desc-summary pkg) + 'font-lock-face 'package-description)]))) + +(defvar package-menu--old-archive-contents nil + "`package-archive-contents' before the latest refresh.") (defun package-menu-refresh () "Download the Emacs Lisp package archive. @@ -1515,32 +2901,57 @@ This fetches the contents of each archive specified in `package-archives', and then refreshes the package menu." (interactive) (unless (derived-mode-p 'package-menu-mode) - (error "The current buffer is not a Package Menu")) - (package-refresh-contents) - (package-menu--generate t t)) + (user-error "The current buffer is not a Package Menu")) + (setq package-menu--old-archive-contents package-archive-contents) + (setq package-menu--new-package-list nil) + (package-refresh-contents package-menu-async)) + +(defun package-menu-hide-package () + "Hide a package under point. +If optional arg BUTTON is non-nil, describe its associated package." + (interactive) + (declare (interactive-only "change `package-hidden-regexps' instead.")) + (let* ((name (when (derived-mode-p 'package-menu-mode) + (concat "\\`" (regexp-quote (symbol-name (package-desc-name + (tabulated-list-get-id))))))) + (re (read-string "Hide packages matching regexp: " name))) + ;; Test if it is valid. + (string-match re "") + (push re package-hidden-regexps) + (customize-save-variable 'package-hidden-regexps package-hidden-regexps) + (package-menu--post-refresh) + (let ((hidden + (cl-remove-if-not (lambda (e) (string-match re (symbol-name (car e)))) + package-archive-contents))) + (message (substitute-command-keys + (concat "Hiding %s packages, type `\\[package-menu-toggle-hiding]'" + " to toggle or `\\[customize-variable] RET package-hidden-regexps'" + " to customize it")) + (length hidden))))) (defun package-menu-describe-package (&optional button) "Describe the current package. If optional arg BUTTON is non-nil, describe its associated package." (interactive) (let ((pkg-desc (if button (button-get button 'package-desc) - (tabulated-list-get-id)))) + (tabulated-list-get-id)))) (if pkg-desc - (describe-package pkg-desc) - (error "No package here")))) + (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" "dependency" "obsolete" "unsigned")) (tabulated-list-put-tag "D" t) (forward-line))) (defun package-menu-mark-install (&optional _num) "Mark a package for installation and move to the next line." (interactive "p") - (if (member (package-menu-get-status) '("available" "new")) + (if (member (package-menu-get-status) '("available" "avail-obso" "new" "dependency")) (tabulated-list-put-tag "I" t) (forward-line))) @@ -1562,72 +2973,216 @@ If optional arg BUTTON is non-nil, describe its associated package." (goto-char (point-min)) (while (not (eobp)) (if (equal (package-menu-get-status) "obsolete") - (tabulated-list-put-tag "D" t) - (forward-line 1))))) + (tabulated-list-put-tag "D" t) + (forward-line 1))))) + +(defvar package--quick-help-keys + '(("install," "delete," "unmark," ("execute" . 1)) + ("next," "previous") + ("Hide-package," "(-toggle-hidden") + ("refresh-contents," "g-redisplay," "filter," "help"))) + +(defun package--prettify-quick-help-key (desc) + "Prettify DESC to be displayed as a help menu." + (if (listp desc) + (if (listp (cdr desc)) + (mapconcat #'package--prettify-quick-help-key desc " ") + (let ((place (cdr desc)) + (out (car desc))) + (add-text-properties place (1+ place) + '(face (bold font-lock-warning-face)) + out) + out)) + (package--prettify-quick-help-key (cons desc 0)))) (defun package-menu-quick-help () - "Show short key binding help for package-menu-mode." + "Show short key binding help for `package-menu-mode'. +The full list of keys can be viewed with \\[describe-mode]." (interactive) - (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp")) + (message (mapconcat #'package--prettify-quick-help-key + package--quick-help-keys "\n"))) (define-obsolete-function-alias 'package-menu-view-commentary 'package-menu-describe-package "24.1") (defun package-menu-get-status () (let* ((id (tabulated-list-get-id)) - (entry (and id (assq id tabulated-list-entries)))) + (entry (and id (assoc id tabulated-list-entries)))) (if entry - (aref (cadr entry) 2) + (aref (cadr entry) 2) ""))) +(defun package-archive-priority (archive) + "Return the priority of ARCHIVE. + +The archive priorities are specified in +`package-archive-priorities'. If not given there, the priority +defaults to 0." + (or (cdr (assoc archive package-archive-priorities)) + 0)) + +(defun package-desc-priority-version (pkg-desc) + "Return the version PKG-DESC with the archive priority prepended. + +This allows for easy comparison of package versions from +different archives if archive priorities are meant to be taken in +consideration." + (cons (package-desc-priority pkg-desc) + (package-desc-version pkg-desc))) + (defun package-menu--find-upgrades () (let (installed available upgrades) ;; Build list of installed/available packages in this buffer. (dolist (entry tabulated-list-entries) ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC]) (let ((pkg-desc (car entry)) - (status (aref (cadr entry) 2))) - (cond ((equal status "installed") - (push pkg-desc installed)) - ((member status '("available" "new")) - (push (cons (package-desc-name pkg-desc) pkg-desc) - available))))) + (status (aref (cadr entry) 2))) + (cond ((member status '("installed" "dependency" "unsigned")) + (push pkg-desc installed)) + ((member status '("available" "new")) + (setq available (package--append-to-alist 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-< (package-desc-version pkg-desc) - (package-desc-version (cdr avail-pkg))) - (push avail-pkg upgrades)))) + (let* ((name (package-desc-name pkg-desc)) + (avail-pkg (cadr (assq name available)))) + (and avail-pkg + (version-list-< (package-desc-priority-version pkg-desc) + (package-desc-priority-version avail-pkg)) + (push (cons name avail-pkg) upgrades)))) upgrades)) -(defun package-menu-mark-upgrades () +(defvar package-menu--mark-upgrades-pending nil + "Whether mark-upgrades is waiting for a refresh to finish.") + +(defun package-menu--mark-upgrades-1 () "Mark all upgradable packages in the Package Menu. -For each installed package with a newer version available, place -an (I)nstall flag on the available version and a (D)elete flag on -the installed version. A subsequent \\[package-menu-execute] -call will upgrade the package." - (interactive) +Implementation of `package-menu-mark-upgrades'." (unless (derived-mode-p 'package-menu-mode) (error "The current buffer is not a Package Menu")) + (setq package-menu--mark-upgrades-pending nil) (let ((upgrades (package-menu--find-upgrades))) (if (null upgrades) - (message "No packages to upgrade.") + (message "No packages to upgrade.") (widen) (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (let* ((pkg-desc (tabulated-list-get-id)) - (upgrade (cdr (assq (package-desc-name pkg-desc) upgrades)))) - (cond ((null upgrade) - (forward-line 1)) - ((equal pkg-desc upgrade) - (package-menu-mark-install)) - (t - (package-menu-mark-delete)))))) + (goto-char (point-min)) + (while (not (eobp)) + (let* ((pkg-desc (tabulated-list-get-id)) + (upgrade (cdr (assq (package-desc-name pkg-desc) upgrades)))) + (cond ((null upgrade) + (forward-line 1)) + ((equal pkg-desc upgrade) + (package-menu-mark-install)) + (t + (package-menu-mark-delete)))))) (message "%d package%s marked for upgrading." - (length upgrades) - (if (= (length upgrades) 1) "" "s"))))) + (length upgrades) + (if (= (length upgrades) 1) "" "s"))))) + +(defun package-menu-mark-upgrades () + "Mark all upgradable packages in the Package Menu. +For each installed package with a newer version available, place +an (I)nstall flag on the available version and a (D)elete flag on +the installed version. A subsequent \\[package-menu-execute] +call will upgrade the package. + +If there's an async refresh operation in progress, the flags will +be placed as part of `package-menu--post-refresh' instead of +immediately." + (interactive) + (if (not package--downloads-in-progress) + (package-menu--mark-upgrades-1) + (setq package-menu--mark-upgrades-pending t) + (message "Waiting for refresh to finish..."))) + +(defun package-menu--list-to-prompt (packages) + "Return a string listing PACKAGES that's usable in a prompt. +PACKAGES is a list of `package-desc' objects. +Formats the returned string to be usable in a minibuffer +prompt (see `package-menu--prompt-transaction-p')." + (cond + ;; None + ((not packages) "") + ;; More than 1 + ((cdr packages) + (format "these %d packages (%s)" + (length packages) + (mapconcat #'package-desc-full-name packages ", "))) + ;; Exactly 1 + (t (format-message "package `%s'" + (package-desc-full-name (car packages)))))) + +(defun package-menu--prompt-transaction-p (delete install upgrade) + "Prompt the user about DELETE, INSTALL, and UPGRADE. +DELETE, INSTALL, and UPGRADE are lists of `package-desc' objects. +Either may be nil, but not all." + (y-or-n-p + (concat + (when delete "Delete ") + (package-menu--list-to-prompt delete) + (when (and delete install) + (if upgrade "; " "; and ")) + (when install "Install ") + (package-menu--list-to-prompt install) + (when (and upgrade (or install delete)) "; and ") + (when upgrade "Upgrade ") + (package-menu--list-to-prompt upgrade) + "? "))) + +(defun package-menu--partition-transaction (install delete) + "Return an alist describing an INSTALL DELETE transaction. +Alist contains three entries, upgrade, delete, and install, each +with a list of package names. + +The upgrade entry contains any `package-desc' objects in INSTALL +whose name coincides with an object in DELETE. The delete and +the install entries are the same as DELETE and INSTALL with such +objects removed." + (let* ((upg (cl-intersection install delete :key #'package-desc-name)) + (ins (cl-set-difference install upg :key #'package-desc-name)) + (del (cl-set-difference delete upg :key #'package-desc-name))) + `((delete . ,del) (install . ,ins) (upgrade . ,upg)))) + +(defun package-menu--perform-transaction (install-list delete-list) + "Install packages in INSTALL-LIST and delete DELETE-LIST." + (if install-list + (let ((status-format (format ":Installing %%d/%d" + (length install-list))) + (i 0) + (package-menu--transaction-status)) + (dolist (pkg install-list) + (setq package-menu--transaction-status + (format status-format (cl-incf i))) + (force-mode-line-update) + (redisplay 'force) + ;; Don't mark as selected, `package-menu-execute' already + ;; does that. + (package-install pkg 'dont-select)))) + (let ((package-menu--transaction-status ":Deleting")) + (force-mode-line-update) + (redisplay 'force) + (dolist (elt (package--sort-by-dependence delete-list)) + (condition-case-unless-debug err + (let ((inhibit-message package-menu-async)) + (package-delete elt nil 'nosave)) + (error (message "Error trying to delete `%s': %S" + (package-desc-full-name elt) + err)))))) + +(defun package--update-selected-packages (add remove) + "Update the `package-selected-packages' list according to ADD and REMOVE. +ADD and REMOVE must be disjoint lists of package names (or +`package-desc' objects) to be added and removed to the selected +packages list, respectively." + (dolist (p add) + (cl-pushnew (if (package-desc-p p) (package-desc-name p) p) + package-selected-packages)) + (dolist (p remove) + (setq package-selected-packages + (remove (if (package-desc-p p) (package-desc-name p) p) + package-selected-packages))) + (when (or add remove) + (package--save-selected-packages package-selected-packages))) (defun package-menu-execute (&optional noquery) "Perform marked Package Menu actions. @@ -1641,84 +3196,140 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (save-excursion (goto-char (point-min)) (while (not (eobp)) - (setq cmd (char-after)) - (unless (eq cmd ?\s) - ;; This is the key PKG-DESC. - (setq pkg-desc (tabulated-list-get-id)) - (cond ((eq cmd ?D) - (push pkg-desc delete-list)) - ((eq cmd ?I) - (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'? " - (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 - (if (or - noquery - (yes-or-no-p - (if (= (length delete-list) 1) - (format "Delete package `%s'? " - (package-desc-full-name (car delete-list))) - (format "Delete these %d packages (%s)? " - (length delete-list) - (mapconcat #'package-desc-full-name - delete-list ", "))))) - (dolist (elt delete-list) - (condition-case-unless-debug err - (package-delete elt) - (error (message (cadr err))))) - (error "Aborted"))) - (if (or delete-list install-list) - (package-menu--generate t t) - (message "No operations specified.")))) + (setq cmd (char-after)) + (unless (eq cmd ?\s) + ;; This is the key PKG-DESC. + (setq pkg-desc (tabulated-list-get-id)) + (cond ((eq cmd ?D) + (push pkg-desc delete-list)) + ((eq cmd ?I) + (push pkg-desc install-list)))) + (forward-line))) + (unless (or delete-list install-list) + (user-error "No operations specified")) + (let-alist (package-menu--partition-transaction install-list delete-list) + (when (or noquery + (package-menu--prompt-transaction-p .delete .install .upgrade)) + (let ((message-template + (concat "Package menu: Operation %s [" + (when .delete (format "Delet__ %s" (length .delete))) + (when (and .delete .install) "; ") + (when .install (format "Install__ %s" (length .install))) + (when (and .upgrade (or .install .delete)) "; ") + (when .upgrade (format "Upgrad__ %s" (length .upgrade))) + "]"))) + (message (replace-regexp-in-string "__" "ing" message-template) "started") + ;; Packages being upgraded are not marked as selected. + (package--update-selected-packages .install .delete) + (package-menu--perform-transaction install-list delete-list) + (when package-selected-packages + (if-let ((removable (package--removable-packages))) + (message "Package menu: Operation finished. %d packages %s" + (length removable) + (substitute-command-keys + "are no longer needed, type `\\[package-autoremove]' to remove them")) + (message (replace-regexp-in-string "__" "ed" message-template) + "finished")))))))) (defun package-menu--version-predicate (A B) (let ((vA (or (aref (cadr A) 1) '(0))) - (vB (or (aref (cadr B) 1) '(0)))) + (vB (or (aref (cadr B) 1) '(0)))) (if (version-list-= vA vB) - (package-menu--name-predicate A B) + (package-menu--name-predicate A B) (version-list-< vA vB)))) (defun package-menu--status-predicate (A B) (let ((sA (aref (cadr A) 2)) - (sB (aref (cadr B) 2))) + (sB (aref (cadr B) 2))) (cond ((string= sA sB) - (package-menu--name-predicate A B)) - ((string= sA "new") t) - ((string= sB "new") nil) - ((string= sA "available") t) - ((string= sB "available") nil) - ((string= sA "installed") t) - ((string= sB "installed") nil) - ((string= sA "held") t) - ((string= sB "held") nil) - ((string= sA "built-in") t) - ((string= sB "built-in") nil) - ((string= sA "obsolete") t) - ((string= sB "obsolete") nil) - (t (string< sA sB))))) + (package-menu--name-predicate A B)) + ((string= sA "new") t) + ((string= sB "new") nil) + ((string-prefix-p "avail" sA) + (if (string-prefix-p "avail" sB) + (package-menu--name-predicate A B) + t)) + ((string-prefix-p "avail" sB) nil) + ((string= sA "installed") t) + ((string= sB "installed") nil) + ((string= sA "dependency") t) + ((string= sB "dependency") nil) + ((string= sA "unsigned") t) + ((string= sB "unsigned") nil) + ((string= sA "held") t) + ((string= sB "held") nil) + ((string= sA "external") t) + ((string= sB "external") nil) + ((string= sA "built-in") t) + ((string= sB "built-in") nil) + ((string= sA "obsolete") t) + ((string= sB "obsolete") nil) + ((string= sA "incompat") t) + ((string= sB "incompat") nil) + (t (string< sA sB))))) (defun package-menu--description-predicate (A B) (let ((dA (aref (cadr A) 3)) - (dB (aref (cadr B) 3))) + (dB (aref (cadr B) 3))) (if (string= dA dB) - (package-menu--name-predicate A B) + (package-menu--name-predicate A B) (string< dA dB)))) (defun package-menu--name-predicate (A B) (string< (symbol-name (package-desc-name (car A))) - (symbol-name (package-desc-name (car B))))) + (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)) ""))) + +(defun package-menu--populate-new-package-list () + "Decide which packages are new in `package-archives-contents'. +Store this list in `package-menu--new-package-list'." + ;; Find which packages are new. + (when package-menu--old-archive-contents + (dolist (elt package-archive-contents) + (unless (assq (car elt) package-menu--old-archive-contents) + (push (car elt) package-menu--new-package-list))) + (setq package-menu--old-archive-contents nil))) + +(defun package-menu--find-and-notify-upgrades () + "Notify the user of upgradable packages." + (when-let ((upgrades (package-menu--find-upgrades))) + (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading." + (length upgrades) + (if (= (length upgrades) 1) "" "s") + (substitute-command-keys "\\[package-menu-mark-upgrades]") + (if (= (length upgrades) 1) "it" "them")))) + +(defun package-menu--post-refresh () + "If there's a *Packages* buffer, revert it and check for new packages and upgrades. +Do nothing if there's no *Packages* buffer. + +This function is called after `package-refresh-contents' and it +is added to `post-command-hook' by any function which alters the +package database (`package-install' and `package-delete'). When +run, it removes itself from `post-command-hook'." + (remove-hook 'post-command-hook #'package-menu--post-refresh) + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (with-current-buffer buf + (package-menu--populate-new-package-list) + (run-hooks 'tabulated-list-revert-hook) + (tabulated-list-print 'remember 'update))))) + +(defun package-menu--mark-or-notify-upgrades () + "If there's a *Packages* buffer, check for upgrades and possibly mark them. +Do nothing if there's no *Packages* buffer. If there are +upgrades, mark them if `package-menu--mark-upgrades-pending' is +non-nil, otherwise just notify the user that there are upgrades. +This function is called after `package-refresh-contents'." + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (with-current-buffer buf + (if package-menu--mark-upgrades-pending + (package-menu--mark-upgrades-1) + (package-menu--find-and-notify-upgrades)))))) ;;;###autoload (defun list-packages (&optional no-fetch) @@ -1731,52 +3342,66 @@ The list is displayed in a buffer named `*Packages*'." ;; Initialize the package system if necessary. (unless package--initialized (package-initialize t)) - (let (old-archives new-packages) - (unless no-fetch - ;; Read the locally-cached archive-contents. - (package-read-all-archive-contents) - (setq old-archives package-archive-contents) + ;; Integrate the package-menu with updating the archives. + (add-hook 'package--post-download-archives-hook + #'package-menu--post-refresh) + (add-hook 'package--post-download-archives-hook + #'package-menu--mark-or-notify-upgrades 'append) + + ;; Generate the Package Menu. + (let ((buf (get-buffer-create "*Packages*"))) + (with-current-buffer buf + (package-menu-mode) + ;; Fetch the remote list of packages. - (package-refresh-contents) - ;; Find which packages are new. - (dolist (elt package-archive-contents) - (unless (assq (car elt) old-archives) - (push (car elt) new-packages)))) - - ;; Generate the Package Menu. - (let ((buf (get-buffer-create "*Packages*"))) - (with-current-buffer buf - (package-menu-mode) - (set (make-local-variable 'package-menu--new-package-list) - new-packages) - (package-menu--generate nil t)) - ;; The package menu buffer has keybindings. If the user types - ;; `M-x list-packages', that suggests it should become current. - (switch-to-buffer buf)) - - (let ((upgrades (package-menu--find-upgrades))) - (if upgrades - (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading." - (length upgrades) - (if (= (length upgrades) 1) "" "s") - (substitute-command-keys "\\[package-menu-mark-upgrades]") - (if (= (length upgrades) 1) "it" "them")))))) + (unless no-fetch (package-menu-refresh)) + + ;; If we're not async, this would be redundant. + (when package-menu-async + (package-menu--generate nil t))) + ;; The package menu buffer has keybindings. If the user types + ;; `M-x list-packages', that suggests it should become current. + (switch-to-buffer buf))) ;;;###autoload (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*"))) + (let* ((buf (get-buffer-create "*Packages*")) + (win (get-buffer-window buf))) (with-current-buffer buf (package-menu-mode) - (package-menu--generate nil packages)) - (switch-to-buffer buf))) + (package-menu--generate nil packages keywords)) + (if win + (select-window win) + (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. +KEYWORD can be a string or a list of strings. If it is a list, a +package will be displayed if it matches any of the keywords. +Interactively, it is a list of strings separated by commas. + +To restore the full package list, type `q'." + (interactive + (list (completing-read-multiple + "Keywords (comma separated): " (package-all-keywords)))) + (package-show-package-list t (if (stringp keyword) + (list keyword) + keyword))) (defun package-list-packages-no-fetch () "Display a list of packages. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index eb2c7f002e8..8bcb447cfbb 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 -*- +;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*- -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: @@ -47,7 +47,7 @@ ;; to be performed anyway, so better do it first so it's shared). ;; - then choose the test that discriminates more (?). ;; - provide Agda's `with' (along with its `...' companion). -;; - implement (not UPAT). This might require a significant redesign. +;; - implement (not PAT). This might require a significant redesign. ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to ;; generate a lex-style DFA to decide whether to run E1 or E2. @@ -68,62 +68,78 @@ (defconst pcase--dontcare-upats '(t _ pcase--dontcare)) +(defvar pcase--dontwarn-upats '(pcase--dontcare)) + (def-edebug-spec - pcase-UPAT + pcase-PAT (&or symbolp - ("or" &rest pcase-UPAT) - ("and" &rest pcase-UPAT) - ("`" pcase-QPAT) + ("or" &rest pcase-PAT) + ("and" &rest pcase-PAT) ("guard" form) - ("let" pcase-UPAT form) - ("pred" - &or lambda-expr - ;; Punt on macros/special forms. - (functionp &rest form) - sexp) + ("let" pcase-PAT form) + ("pred" pcase-FUN) + ("app" pcase-FUN pcase-PAT) + pcase-MACRO sexp)) (def-edebug-spec - pcase-QPAT - (&or ("," pcase-UPAT) - (pcase-QPAT . pcase-QPAT) + pcase-FUN + (&or lambda-expr + ;; Punt on macros/special forms. + (functionp &rest form) sexp)) +(def-edebug-spec pcase-MACRO pcase--edebug-match-macro) + +;; Only called from edebug. +(declare-function get-edebug-spec "edebug" (symbol)) +(declare-function edebug-match "edebug" (cursor specs)) + +(defun pcase--edebug-match-macro (cursor) + (let (specs) + (mapatoms + (lambda (s) + (let ((m (get s 'pcase-macroexpander))) + (when (and m (get-edebug-spec m)) + (push (cons (symbol-name s) (get-edebug-spec m)) + specs))))) + (edebug-match cursor (cons '&or specs)))) + ;;;###autoload (defmacro pcase (exp &rest cases) "Perform ML-style pattern matching on EXP. -CASES is a list of elements of the form (UPATTERN CODE...). +CASES is a list of elements of the form (PATTERN CODE...). -UPatterns can take the following forms: +Patterns can take the following forms: _ matches anything. - SELFQUOTING matches itself. This includes keywords, numbers, and strings. SYMBOL matches anything and binds it to SYMBOL. - (or UPAT...) matches if any of the patterns matches. - (and UPAT...) matches if all the patterns match. - `QPAT matches if the QPattern QPAT matches. - (pred PRED) matches if PRED applied to the object returns non-nil. + (or PAT...) matches if any of the patterns matches. + (and PAT...) matches if all the patterns match. + \\='VAL matches if the object is `equal' to VAL + ATOM is a shorthand for \\='ATOM. + ATOM can be a keyword, an integer, or a string. + (pred FUN) matches if FUN applied to the object returns non-nil. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. - (let UPAT EXP) matches if EXP matches UPAT. + (let PAT EXP) matches if EXP matches PAT. + (app FUN PAT) matches if FUN applied to the object matches PAT. If a SYMBOL is used twice in the same pattern (i.e. the pattern is \"non-linear\"), then the second occurrence is turned into an `eq'uality test. -QPatterns can take the following forms: - (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. - ,UPAT matches if the UPattern UPAT matches. - STRING matches if the object is `equal' to STRING. - ATOM matches if the object is `eq' to ATOM. -QPatterns for vectors are not implemented yet. - -PRED can take the form - FUNCTION in which case it gets called with one argument. - (FUN ARG1 .. ARGN) in which case it gets called with an N+1'th argument +FUN can take the form + SYMBOL or (lambda ARGS BODY) in which case it's called with one argument. + (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument which is the value being matched. -A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION). -PRED patterns can refer to variables bound earlier in the pattern. +So a FUN of the form SYMBOL is equivalent to one of the form (FUN). +FUN can refer to variables bound earlier in the pattern. +FUN is assumed to be pure, i.e. it can be dropped if its result is not used, +and two identical calls can be merged into one. E.g. you can match pairs where the cdr is larger than the car with a pattern -like `(,a . ,(pred (< a))) or, with more checks: -`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" - (declare (indent 1) (debug (form &rest (pcase-UPAT body)))) +like \\=`(,a . ,(pred (< a))) or, with more checks: +\\=`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a)))) + +Additional patterns can be defined via `pcase-defmacro'. +Currently, the following patterns are provided this way:" + (declare (indent 1) (debug (form &rest (pcase-PAT body)))) ;; We want to use a weak hash table as a cache, but the key will unavoidably ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time ;; we're called so it'll be immediately GC'd. So we use (car cases) as key @@ -147,6 +163,65 @@ like `(,a . ,(pred (< a))) or, with more checks: ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2) expansion)))) +(declare-function help-fns--signature "help-fns" + (function doc real-def real-function buffer)) + +;; FIXME: Obviously, this will collide with nadvice's use of +;; function-documentation if we happen to advise `pcase'. +(put 'pcase 'function-documentation '(pcase--make-docstring)) +(defun pcase--make-docstring () + (let* ((main (documentation (symbol-function 'pcase) 'raw)) + (ud (help-split-fundoc main 'pcase))) + ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works, + ;; where cl-lib is anything using pcase-defmacro. + (require 'help-fns) + (with-temp-buffer + (insert (or (cdr ud) main)) + (mapatoms + (lambda (symbol) + (let ((me (get symbol 'pcase-macroexpander))) + (when me + (insert "\n\n-- ") + (let* ((doc (documentation me 'raw))) + (setq doc (help-fns--signature symbol doc me + (indirect-function me) nil)) + (insert "\n" (or doc "Not documented."))))))) + (let ((combined-doc (buffer-string))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) + +;;;###autoload +(defmacro pcase-exhaustive (exp &rest cases) + "The exhaustive version of `pcase' (which see)." + (declare (indent 1) (debug pcase)) + (let* ((x (make-symbol "x")) + (pcase--dontwarn-upats (cons x pcase--dontwarn-upats))) + (pcase--expand + ;; FIXME: Could we add the FILE:LINE data in the error message? + exp (append cases `((,x (error "No clause matching `%S'" ,x))))))) + +;;;###autoload +(defmacro pcase-lambda (lambda-list &rest body) + "Like `lambda' but allow each argument to be a pattern. +I.e. accepts the usual &optional and &rest keywords, but every +formal argument can be any pattern accepted by `pcase' (a mere +variable name being but a special case of it)." + (declare (doc-string 2) (indent defun) + (debug ((&rest pcase-PAT) body))) + (let* ((bindings ()) + (parsed-body (macroexp-parse-body body)) + (args (mapcar (lambda (pat) + (if (symbolp pat) + ;; Simple vars and &rest/&optional are just passed + ;; through unchanged. + pat + (let ((arg (make-symbol + (format "arg%s" (length bindings))))) + (push `(,pat ,arg) bindings) + arg))) + lambda-list))) + `(lambda ,args ,@(car parsed-body) + (pcase-let* ,(nreverse bindings) ,@(cdr parsed-body))))) + (defun pcase--let* (bindings body) (cond ((null bindings) (macroexp-progn body)) @@ -168,9 +243,9 @@ like `(,a . ,(pred (< a))) or, with more checks: (defmacro pcase-let* (bindings &rest body) "Like `let*' but where you can use `pcase' patterns for bindings. BODY should be an expression, and BINDINGS should be a list of bindings -of the form (UPAT EXP)." +of the form (PAT EXP)." (declare (indent 1) - (debug ((&rest (pcase-UPAT &optional form)) body))) + (debug ((&rest (pcase-PAT &optional form)) body))) (let ((cached (gethash bindings pcase--memoize))) ;; cached = (BODY . EXPANSION) (if (equal (car cached) body) @@ -183,7 +258,10 @@ of the form (UPAT EXP)." (defmacro pcase-let (bindings &rest body) "Like `let' but where you can use `pcase' patterns for bindings. BODY should be a list of expressions, and BINDINGS should be a list of bindings -of the form (UPAT EXP)." +of the form (PAT EXP). +The macro is expanded and optimized under the assumption that those +patterns *will* match, so a mismatch may go undetected or may cause +any kind of error." (declare (indent 1) (debug pcase-let*)) (if (null (cdr bindings)) `(pcase-let* ,bindings ,@body) @@ -199,8 +277,9 @@ of the form (UPAT EXP)." (push (list (car binding) tmpvar) matches))))) `(let ,(nreverse bindings) (pcase-let* ,matches ,@body))))) +;;;###autoload (defmacro pcase-dolist (spec &rest body) - (declare (indent 1) (debug ((pcase-UPAT form) body))) + (declare (indent 1) (debug ((pcase-PAT form) body))) (if (pcase--trivial-upat-p (car spec)) `(dolist ,spec ,@body) (let ((tmpvar (make-symbol "x"))) @@ -265,7 +344,7 @@ of the form (UPAT EXP)." (main (pcase--u (mapcar (lambda (case) - `((match ,val . ,(car case)) + `(,(pcase--match val (pcase--macroexpand (car case))) ,(lambda (vars) (unless (memq case used-cases) ;; Keep track of the cases that are used. @@ -279,10 +358,59 @@ of the form (UPAT EXP)." vars)))) cases)))) (dolist (case cases) - (unless (or (memq case used-cases) (eq (car case) 'pcase--dontcare)) + (unless (or (memq case used-cases) + (memq (car case) pcase--dontwarn-upats)) (message "Redundant pcase pattern: %S" (car case)))) (macroexp-let* defs main)))) +(defun pcase--macroexpand (pat) + "Expands all macro-patterns in PAT." + (let ((head (car-safe pat))) + (cond + ((null head) + (if (pcase--self-quoting-p pat) `',pat pat)) + ((memq head '(pred guard quote)) pat) + ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat)))) + ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat))) + ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) + (t + (let* ((expander (get head 'pcase-macroexpander)) + (npat (if expander (apply expander (cdr pat))))) + (if (null npat) + (error (if expander + "Unexpandable %s pattern: %S" + "Unknown %s pattern: %S") + head pat) + (pcase--macroexpand npat))))))) + +;;;###autoload +(defmacro pcase-defmacro (name args &rest body) + "Define a new kind of pcase PATTERN, by macro expansion. +Patterns of the form (NAME ...) will be expanded according +to this macro." + (declare (indent 2) (debug defun) (doc-string 3)) + ;; Add the function via `fsym', so that an autoload cookie placed + ;; on a pcase-defmacro will cause the macro to be loaded on demand. + (let ((fsym (intern (format "%s--pcase-macroexpander" name))) + (decl (assq 'declare body))) + (when decl (setq body (remove decl body))) + `(progn + (defun ,fsym ,args ,@body) + (put ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl))) + (put ',name 'pcase-macroexpander #',fsym)))) + +(defun pcase--match (val upat) + "Build a MATCH structure, hoisting all `or's and `and's outside." + (cond + ;; Hoist or/and patterns into or/and matches. + ((memq (car-safe upat) '(or and)) + `(,(car upat) + ,@(mapcar (lambda (upat) + (pcase--match val upat)) + (cdr upat)))) + (t + `(match ,val . ,upat)))) + (defun pcase-codegen (code vars) ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy @@ -306,11 +434,6 @@ of the form (UPAT EXP)." ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen? (t (macroexp-if test then else)))) -(defun pcase--upat (qpattern) - (cond - ((eq (car-safe qpattern) '\,) (cadr qpattern)) - (t (list '\` qpattern)))) - ;; Note about MATCH: ;; When we have patterns like `(PAT1 . PAT2), after performing the `consp' ;; check, we want to turn all the similar patterns into ones of the form @@ -335,7 +458,7 @@ Each BRANCH has the form (MATCH CODE . VARS) where CODE is the code generator for that branch. VARS is the set of vars already bound by earlier matches. MATCH is the pattern that needs to be matched, of the form: - (match VAR . UPAT) + (match VAR . PAT) (and MATCH ...) (or MATCH ...)" (when (setq branches (delq nil branches)) @@ -383,21 +506,12 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--split-match (sym splitter match) (cond - ((eq (car match) 'match) + ((eq (car-safe match) 'match) (if (not (eq sym (cadr match))) (cons match match) - (let ((pat (cddr match))) - (cond - ;; Hoist `or' and `and' patterns to `or' and `and' matches. - ((memq (car-safe pat) '(or and)) - (pcase--split-match sym splitter - (cons (car pat) - (mapcar (lambda (alt) - `(match ,sym . ,alt)) - (cdr pat))))) - (t (let ((res (funcall splitter (cddr match)))) - (cons (or (car res) match) (or (cdr res) match)))))))) - ((memq (car match) '(or and)) + (let ((res (funcall splitter (cddr match)))) + (cons (or (car res) match) (or (cdr res) match))))) + ((memq (car-safe match) '(or and)) (let ((then-alts '()) (else-alts '()) (neutral-elem (if (eq 'or (car match)) @@ -417,6 +531,7 @@ MATCH is the pattern that needs to be matched, of the form: ((null else-alts) neutral-elem) ((null (cdr else-alts)) (car else-alts)) (t (cons (car match) (nreverse else-alts))))))) + ((memq match '(:pcase--succeed :pcase--fail)) (cons match match)) (t (error "Uknown MATCH %s" match)))) (defun pcase--split-rest (sym splitter rest) @@ -433,27 +548,13 @@ MATCH is the pattern that needs to be matched, of the form: (push (cons (cdr split) code&vars) else-rest)))) (cons (nreverse then-rest) (nreverse else-rest)))) -(defun pcase--split-consp (syma symd pat) - (cond - ;; A QPattern for a cons, can only go the `then' side. - ((and (eq (car-safe pat) '\`) (consp (cadr pat))) - (let ((qpat (cadr pat))) - (cons `(and (match ,syma . ,(pcase--upat (car qpat))) - (match ,symd . ,(pcase--upat (cdr qpat)))) - :pcase--fail))) - ;; A QPattern but not for a cons, can only go to the `else' side. - ((eq (car-safe pat) '\`) '(:pcase--fail . nil)) - ((and (eq (car-safe pat) 'pred) - (pcase--mutually-exclusive-p #'consp (cadr pat))) - '(:pcase--fail . nil)))) - (defun pcase--split-equal (elem pat) (cond ;; The same match will give the same result. - ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) + ((and (eq (car-safe pat) 'quote) (equal (cadr pat) elem)) '(:pcase--succeed . :pcase--fail)) ;; A different match will fail if this one succeeds. - ((and (eq (car-safe pat) '\`) + ((and (eq (car-safe pat) 'quote) ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) @@ -461,11 +562,13 @@ 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) + ;; FIXME: The new pred-based member code doesn't do these optimizations! ;; Based on pcase--split-equal. (cond ;; The same match (or a match of membership in a superset) will @@ -473,10 +576,10 @@ MATCH is the pattern that needs to be matched, of the form: ;; (??? ;; '(:pcase--succeed . nil)) ;; A match for one of the elements may succeed or fail. - ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) + ((and (eq (car-safe pat) 'quote) (member (cadr pat) elems)) nil) ;; A different match will fail if this one succeeds. - ((and (eq (car-safe pat) '\`) + ((and (eq (car-safe pat) 'quote) ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) @@ -484,10 +587,11 @@ 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 (vars upat pat) @@ -506,15 +610,16 @@ MATCH is the pattern that needs to be matched, of the form: ((and (eq 'pred (car upat)) (let ((otherpred (cond ((eq 'pred (car-safe pat)) (cadr pat)) - ((not (eq '\` (car-safe pat))) nil) + ((not (eq 'quote (car-safe pat))) nil) ((consp (cadr pat)) #'consp) + ((stringp (cadr pat)) #'stringp) ((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)) + (eq 'quote (car-safe pat)) (symbolp (cadr upat)) (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) (get (cadr upat) 'side-effect-free) @@ -534,12 +639,73 @@ MATCH is the pattern that needs to be matched, of the form: res)) (defun pcase--self-quoting-p (upat) - (or (keywordp upat) (numberp upat) (stringp upat))) + (or (keywordp upat) (integerp upat) (stringp upat))) + +(defun pcase--app-subst-match (match sym fun nsym) + (cond + ((eq (car-safe match) 'match) + (if (and (eq sym (cadr match)) + (eq 'app (car-safe (cddr match))) + (equal fun (nth 1 (cddr match)))) + (pcase--match nsym (nth 2 (cddr match))) + match)) + ((memq (car-safe match) '(or and)) + `(,(car match) + ,@(mapcar (lambda (match) + (pcase--app-subst-match match sym fun nsym)) + (cdr match)))) + ((memq match '(:pcase--succeed :pcase--fail)) match) + (t (error "Uknown MATCH %s" match)))) + +(defun pcase--app-subst-rest (rest sym fun nsym) + (mapcar (lambda (branch) + `(,(pcase--app-subst-match (car branch) sym fun nsym) + ,@(cdr branch))) + rest)) (defsubst pcase--mark-used (sym) ;; Exceptionally, `sym' may be a constant expression rather than a symbol. (if (symbolp sym) (put sym 'pcase-used t))) +(defmacro pcase--flip (fun arg1 arg2) + "Helper function, used internally to avoid (funcall (lambda ...) ...)." + (declare (debug (sexp body))) + `(,fun ,arg2 ,arg1)) + +(defun pcase--funcall (fun arg vars) + "Build a function call to FUN with arg ARG." + (if (symbolp fun) + `(,fun ,arg) + (let* (;; `vs' is an upper bound on the vars we need. + (vs (pcase--fgrep (mapcar #'car vars) fun)) + (env (mapcar (lambda (var) + (list var (cdr (assq var vars)))) + vs)) + (call (progn + (when (memq arg vs) + ;; `arg' is shadowed by `env'. + (let ((newsym (make-symbol "x"))) + (push (list newsym arg) env) + (setq arg newsym))) + (if (functionp fun) + `(funcall #',fun ,arg) + `(,@fun ,arg))))) + (if (null vs) + call + ;; Let's not replace `vars' in `fun' since it's + ;; too difficult to do it right, instead just + ;; let-bind `vars' around `fun'. + `(let* ,env ,call))))) + +(defun pcase--eval (exp vars) + "Build an expression that will evaluate EXP." + (let* ((found (assq exp vars))) + (if found (cdr found) + (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) + (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) + vs))) + (if env (macroexp-let* env exp) exp))))) + ;; It's very tempting to use `pcase' below, tho obviously, it'd create ;; bootstrapping problems. (defun pcase--u1 (matches code vars rest) @@ -561,22 +727,26 @@ Otherwise, it defers to REST which is a list of branches of the form ((eq 'or (caar matches)) (let* ((alts (cdar matches)) (var (if (eq (caar alts) 'match) (cadr (car alts)))) - (simples '()) (others '())) + (simples '()) (others '()) (memq-ok t)) (when var (dolist (alt alts) (if (and (eq (car alt) 'match) (eq var (cadr alt)) (let ((upat (cddr alt))) - (and (eq (car-safe upat) '\`) - (or (integerp (cadr upat)) (symbolp (cadr upat)) - (stringp (cadr upat)))))) - (push (cddr alt) simples) + (eq (car-safe upat) 'quote))) + (let ((val (cadr (cddr alt)))) + (unless (or (integerp val) (symbolp val)) + (setq memq-ok nil)) + (push (cadr (cddr alt)) simples)) (push alt others)))) (cond ((null alts) (error "Please avoid it") (pcase--u rest)) + ;; Yes, we can use `memq' (or `member')! ((> (length simples) 1) - ;; De-hoist the `or' MATCH into an `or' pattern that will be - ;; turned into a `memq' below. - (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) + (pcase--u1 (cons `(match ,var + . (pred (pcase--flip + ,(if memq-ok #'memq #'member) + ',simples))) + (cdr matches)) code vars (if (null others) rest (cons (cons @@ -601,7 +771,12 @@ Otherwise, it defers to REST which is a list of branches of the form (sym (car cdrpopmatches)) (upat (cdr cdrpopmatches))) (cond - ((memq upat '(t _)) (pcase--u1 matches code vars rest)) + ((memq upat '(t _)) + (let ((code (pcase--u1 matches code vars rest))) + (if (eq upat '_) code + (macroexp--warn-and-return + "Pattern t is deprecated. Use `_' instead" + code)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) ((memq (car-safe upat) '(guard pred)) (if (eq (car upat) 'pred) (pcase--mark-used sym)) @@ -610,36 +785,12 @@ Otherwise, it defers to REST which is a list of branches of the form 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))) - `(,(cadr upat) ,sym) - (let* ((exp (cadr upat)) - ;; `vs' is an upper bound on the vars we need. - (vs (pcase--fgrep (mapcar #'car vars) exp)) - (env (mapcar (lambda (var) - (list var (cdr (assq var vars)))) - vs)) - (call (if (eq 'guard (car upat)) - exp - (when (memq sym vs) - ;; `sym' is shadowed by `env'. - (let ((newsym (make-symbol "x"))) - (push (list newsym sym) env) - (setq sym newsym))) - (if (functionp exp) - `(funcall #',exp ,sym) - `(,@exp ,sym))))) - (if (null vs) - call - ;; Let's not replace `vars' in `exp' since it's - ;; too difficult to do it right, instead just - ;; let-bind `vars' around `exp'. - `(let* ,env ,call)))) + (pcase--if (if (eq (car upat) 'pred) + (pcase--funcall (cadr upat) sym vars) + (pcase--eval (cadr upat) vars)) (pcase--u1 matches code vars then-rest) (pcase--u else-rest)))) - ((pcase--self-quoting-p upat) - (pcase--mark-used sym) - (pcase--q1 sym upat matches code vars rest)) - ((symbolp upat) + ((and (symbolp upat) upat) (pcase--mark-used sym) (if (not (assq upat vars)) (pcase--u1 matches code (cons (cons upat sym) vars) rest) @@ -653,57 +804,41 @@ Otherwise, it defers to REST which is a list of branches of the form ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) (macroexp-let2 macroexp-copyable-p sym - (let* ((exp (nth 2 upat)) - (found (assq exp vars))) - (if found (cdr found) - (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) - (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) - vs))) - (if env (macroexp-let* env exp) exp)))) - (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) + (pcase--eval (nth 2 upat) vars) + (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches) code vars rest))) - ((eq (car-safe upat) '\`) + ((eq (car-safe upat) 'app) + ;; A upat of the form (app FUN PAT) (pcase--mark-used sym) - (pcase--q1 sym (cadr upat) matches code vars rest)) - ((eq (car-safe upat) 'or) - (let ((all (> (length (cdr upat)) 1)) - (memq-fine t)) - (when all - (dolist (alt (cdr upat)) - (unless (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. - (let* ((elems (mapcar (lambda (x) (if (consp x) (cadr x) x)) - (cdr upat))) - (splitrest - (pcase--split-rest - sym (lambda (pat) (pcase--split-member elems pat)) rest)) - (then-rest (car splitrest)) - (else-rest (cdr splitrest))) - (pcase--mark-used sym) - (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) - (pcase--u1 matches code vars then-rest) - (pcase--u else-rest))) - (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars - (append (mapcar (lambda (upat) - `((and (match ,sym . ,upat) ,@matches) - ,code ,@vars)) - (cddr upat)) - rest))))) - ((eq (car-safe upat) 'and) - (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) - (cdr upat)) - matches) - code vars rest)) + (let* ((fun (nth 1 upat)) + (nsym (make-symbol "x")) + (body + ;; We don't change `matches' to reuse the newly computed value, + ;; because we assume there shouldn't be such redundancy in there. + (pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches) + code vars + (pcase--app-subst-rest rest sym fun nsym)))) + (if (not (get nsym 'pcase-used)) + body + (macroexp-let* + `((,nsym ,(pcase--funcall fun sym vars))) + body)))) + ((eq (car-safe upat) 'quote) + (pcase--mark-used sym) + (let* ((val (cadr upat)) + (splitrest (pcase--split-rest + sym (lambda (pat) (pcase--split-equal val pat)) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) + (pcase--if (cond + ((null val) `(null ,sym)) + ((or (integerp val) (symbolp val)) + (if (pcase--self-quoting-p val) + `(eq ,sym ,val) + `(eq ,sym ',val))) + (t `(equal ,sym ',val))) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest)))) ((eq (car-safe upat) 'not) ;; FIXME: The implementation below is naive and results in ;; inefficient code. @@ -725,57 +860,42 @@ Otherwise, it defers to REST which is a list of branches of the form (pcase--u rest)) vars (list `((and . ,matches) ,code . ,vars)))) - (t (error "Unknown upattern `%s'" upat))))) - (t (error "Incorrect MATCH %s" (car matches))))) + (t (error "Unknown pattern `%S'" upat))))) + (t (error "Incorrect MATCH %S" (car matches))))) -(defun pcase--q1 (sym qpat matches code vars rest) - "Return code that runs CODE if SYM matches QPAT and if MATCHES match. -Otherwise, it defers to REST which is a list of branches of the form -\(OTHER_MATCH OTHER-CODE . OTHER-VARS)." +(def-edebug-spec + pcase-QPAT + (&or ("," pcase-PAT) + (pcase-QPAT . pcase-QPAT) + (vector &rest pcase-QPAT) + sexp)) + +(pcase-defmacro \` (qpat) + "Backquote-style pcase patterns. +QPAT can take the following forms: + (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. + [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match + its 0..(n-1)th elements, respectively. + ,PAT matches if the pcase pattern PAT matches. + ATOM matches if the object is `equal' to ATOM. + ATOM can be a symbol, an integer, or a string." + (declare (debug (pcase-QPAT))) (cond - ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN")) - ((floatp qpat) (error "Floating point patterns not supported")) + ((eq (car-safe qpat) '\,) (cadr qpat)) ((vectorp qpat) - ;; FIXME. - (error "Vector QPatterns not implemented yet")) + `(and (pred vectorp) + (app length ,(length qpat)) + ,@(let ((upats nil)) + (dotimes (i (length qpat)) + (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i))) + upats)) + (nreverse upats)))) ((consp qpat) - (let* ((syma (make-symbol "xcar")) - (symd (make-symbol "xcdr")) - (splitrest (pcase--split-rest - sym - (lambda (pat) (pcase--split-consp syma symd pat)) - rest)) - (then-rest (car splitrest)) - (else-rest (cdr splitrest)) - (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) - (match ,symd . ,(pcase--upat (cdr qpat))) - ,@matches) - code vars then-rest))) - (pcase--if - `(consp ,sym) - ;; We want to be careful to only add bindings that are used. - ;; The byte-compiler could do that for us, but it would have to pay - ;; attention to the `consp' test in order to figure out that car/cdr - ;; can't signal errors and our byte-compiler is not that clever. - ;; FIXME: Some of those let bindings occur too early (they are used in - ;; `then-body', but only within some sub-branch). - (macroexp-let* - `(,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) - ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) - then-body) - (pcase--u else-rest)))) - ((or (integerp qpat) (symbolp qpat) (stringp qpat)) - (let* ((splitrest (pcase--split-rest - sym (lambda (pat) (pcase--split-equal qpat pat)) rest)) - (then-rest (car splitrest)) - (else-rest (cdr splitrest))) - (pcase--if (cond - ((stringp qpat) `(equal ,sym ,qpat)) - ((null qpat) `(null ,sym)) - (t `(eq ,sym ',qpat))) - (pcase--u1 matches code vars then-rest) - (pcase--u else-rest)))) - (t (error "Unknown QPattern %s" qpat)))) + `(and (pred consp) + (app car ,(list '\` (car qpat))) + (app cdr ,(list '\` (cdr qpat))))) + ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat) + (t (error "Unknown QPAT: %S" qpat)))) (provide 'pcase) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 4cb089aca97..ac3cc74ca6a 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-2015 Free Software Foundation, Inc. ;; Author: Randal Schwartz <merlyn@stonehenge.com> ;; Keywords: lisp @@ -129,7 +129,7 @@ Also add the value to the front of the list in the variable `values'." (interactive (list (read--expression "Eval: "))) (message "Evaluating...") - (setq values (cons (eval expression) values)) + (setq values (cons (eval expression lexical-binding) values)) (pp-display-expression (car values) "*Pp Eval Output*")) ;;;###autoload @@ -137,7 +137,7 @@ Also add the value to the front of the list in the variable `values'." "Macroexpand EXPRESSION and pretty-print its value." (interactive (list (read--expression "Macroexpand: "))) - (pp-display-expression (macroexpand expression) "*Pp Macroexpand Output*")) + (pp-display-expression (macroexpand-1 expression) "*Pp Macroexpand Output*")) (defun pp-last-sexp () "Read sexp before point. Ignores leading comment characters." @@ -165,7 +165,7 @@ With argument, pretty-print output into current buffer. Ignores leading comment characters." (interactive "P") (if arg - (insert (pp-to-string (eval (pp-last-sexp)))) + (insert (pp-to-string (eval (pp-last-sexp) lexical-binding))) (pp-eval-expression (pp-last-sexp)))) ;;;###autoload @@ -175,7 +175,7 @@ With argument, pretty-print output into current buffer. Ignores leading comment characters." (interactive "P") (if arg - (insert (pp-to-string (macroexpand (pp-last-sexp)))) + (insert (pp-to-string (macroexpand-1 (pp-last-sexp)))) (pp-macroexpand-expression (pp-last-sexp)))) ;;; Test cases for quote diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index d463bfac412..a499b038b93 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-2015 Free Software Foundation, Inc. ;; Author: Detlev Zundel <dzu@gnu.org> ;; Keywords: matching, lisp, tools diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index de9966c0af0..e315733e222 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-2015 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. @@ -92,7 +92,7 @@ is enclosed by at least one regexp grouping construct. The returned regexp is typically more efficient than the equivalent regexp: (let ((open (if PAREN \"\\\\(\" \"\")) (close (if PAREN \"\\\\)\" \"\"))) - (concat open (mapconcat 'regexp-quote STRINGS \"\\\\|\") close)) + (concat open (mapconcat \\='regexp-quote STRINGS \"\\\\|\") close)) If PAREN is `words', then the resulting regexp is additionally surrounded by \\=\\< and \\>. @@ -143,7 +143,7 @@ If LAX non-nil, don't output parentheses if it doesn't require them. Merges keywords to avoid backtracking in Emacs's regexp matcher." ;; The basic idea is to find the shortest common prefix or suffix, remove it ;; and recurse. If there is no prefix, we divide the list into two so that - ;; \(at least) one half will have at least a one-character common prefix. + ;; (at least) one half will have at least a one-character common prefix. ;; Also we delay the addition of grouping parenthesis as long as possible ;; until we're sure we need them, and try to remove one-character sequences @@ -205,9 +205,7 @@ Merges keywords to avoid backtracking in Emacs's regexp matcher." (regexp-opt-group suffixes t t) close-group)) - (let* ((sgnirts (mapcar (lambda (s) - (concat (nreverse (string-to-list s)))) - strings)) + (let* ((sgnirts (mapcar #'reverse strings)) (xiffus (try-completion "" sgnirts))) (if (> (length xiffus) 0) ;; common suffix: take it and recurse on the prefixes. @@ -218,8 +216,7 @@ Merges keywords to avoid backtracking in Emacs's regexp matcher." 'string-lessp))) (concat open-group (regexp-opt-group prefixes t t) - (regexp-quote - (concat (nreverse (string-to-list xiffus)))) + (regexp-quote (nreverse xiffus)) close-group)) ;; Otherwise, divide the list into those that start with a @@ -285,7 +282,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..2b317f6e253 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-2015 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..2447dfa8e38 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-2015 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..a5ff9722698 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-2015 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) @@ -767,8 +768,8 @@ of all atomic regexps." ((= l 3) (string-match "\\`\\(?:\\\\[cCsS_]\\|\\[[^^]\\]\\)" r)) ((null lax) (cond - ((string-match "\\`\\[^?\]?\\(?:\\[:[a-z]+:]\\|[^\]]\\)*\\]\\'" r)) - ((string-match "\\`\\\\(\\(?:[^\\]\\|\\\\[^\)]\\)*\\\\)\\'" r))))))) + ((string-match "\\`\\[^?\]?\\(?:\\[:[a-z]+:]\\|[^]]\\)*\\]\\'" r)) + ((string-match "\\`\\\\(\\(?:[^\\]\\|\\\\[^)]\\)*\\\\)\\'" r))))))) (defun rx-syntax (form) @@ -814,9 +815,9 @@ of all atomic regexps." (defun rx-greedy (form) "Parse and produce code from FORM. -If FORM is '(minimal-match FORM1)', non-greedy versions of `*', +If FORM is `(minimal-match FORM1)', non-greedy versions of `*', `+', and `?' operators will be used in FORM1. If FORM is -'(maximal-match FORM1)', greedy operators will be used." +`(maximal-match FORM1)', greedy operators will be used." (rx-check form) (let ((rx-greedy-flag (eq (car form) 'maximal-match))) (rx-form (cadr form) rx-parent))) @@ -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 @@ -964,20 +965,20 @@ CHAR matches space and tab only. `graphic', `graph' - matches graphic characters--everything except ASCII control chars, - space, and DEL. + matches graphic characters--everything except whitespace, ASCII + and non-ASCII control characters, surrogates, and codepoints + unassigned by Unicode. `printing', `print' - matches printing characters--everything except ASCII control chars - and DEL. + matches whitespace and graphic characters. `alphanumeric', `alnum' - matches letters and digits. (But at present, for multibyte characters, - it matches anything that has word syntax.) + matches alphabetic characters and digits. (For multibyte characters, + it matches according to Unicode character properties.) `letter', `alphabetic', `alpha' - matches letters. (But at present, for multibyte characters, - it matches anything that has word syntax.) + matches alphabetic characters. (For multibyte characters, + it matches according to Unicode character properties.) `ascii' matches ASCII (unibyte) characters. @@ -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/seq.el b/lisp/emacs-lisp/seq.el new file mode 100644 index 00000000000..68265094c17 --- /dev/null +++ b/lisp/emacs-lisp/seq.el @@ -0,0 +1,487 @@ +;;; seq.el --- Sequence manipulation functions -*- lexical-binding: t -*- + +;; Copyright (C) 2014-2015 Free Software Foundation, Inc. + +;; Author: Nicolas Petton <nicolas@petton.fr> +;; Keywords: sequences +;; Version: 2.2 +;; Package: seq + +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Sequence-manipulation functions that complement basic functions +;; provided by subr.el. +;; +;; All functions are prefixed with "seq-". +;; +;; All provided functions work on lists, strings and vectors. +;; +;; Functions taking a predicate or iterating over a sequence using a +;; function as argument take the function as their first argument and +;; the sequence as their second argument. All other functions take +;; the sequence as their first argument. +;; +;; While seq.el version 1.8 is in GNU ELPA for convenience, seq.el +;; version 2.0 requires Emacs>=25.1. +;; +;; seq.el can be extended to support new type of sequences. Here are +;; the generic functions that must be implemented by new seq types: +;; - `seq-elt' +;; - `seq-length' +;; - `seq-do' +;; - `seq-p' +;; - `seq-subseq' +;; - `seq-into-sequence' +;; - `seq-copy' +;; - `seq-into' +;; +;; All functions are tested in test/automated/seq-tests.el + +;;; Code: + +(eval-when-compile (require 'cl-generic)) +(require 'cl-extra) ;; for cl-subseq + +(defmacro seq-doseq (spec &rest body) + "Loop over a sequence. +Evaluate BODY with VAR bound to each element of SEQUENCE, in turn. + +Similar to `dolist' but can be applied to lists, strings, and vectors. + +\(fn (VAR SEQUENCE) BODY...)" + (declare (indent 1) (debug ((symbolp form &optional form) body))) + `(seq-do (lambda (,(car spec)) + ,@body) + ,(cadr spec))) + +(pcase-defmacro seq (&rest patterns) + "Build a `pcase' pattern that matches elements of SEQUENCE. + +The `pcase' pattern will match each element of PATTERNS against the +corresponding element of SEQUENCE. + +Extra elements of the sequence are ignored if fewer PATTERNS are +given, and the match does not fail." + `(and (pred seq-p) + ,@(seq--make-pcase-bindings patterns))) + +(defmacro seq-let (args sequence &rest body) + "Bind the variables in ARGS to the elements of SEQUENCE, then evaluate BODY. + +ARGS can also include the `&rest' marker followed by a variable +name to be bound to the rest of SEQUENCE." + (declare (indent 2) (debug t)) + `(pcase-let ((,(seq--make-pcase-patterns args) ,sequence)) + ,@body)) + + +;;; Basic seq functions that have to be implemented by new sequence types +(cl-defgeneric seq-elt (sequence n) + "Return Nth element of SEQUENCE." + (elt sequence n)) + +;; Default gv setters for `seq-elt'. +;; It can be a good idea for new sequence implementations to provide a +;; "gv-setter" for `seq-elt'. +(cl-defmethod (setf seq-elt) (store (sequence array) n) + (aset sequence n store)) + +(cl-defmethod (setf seq-elt) (store (sequence cons) n) + (setcar (nthcdr n sequence) store)) + +(cl-defgeneric seq-length (sequence) + "Return the number of elements of SEQUENCE." + (length sequence)) + +(cl-defgeneric seq-do (function sequence) + "Apply FUNCTION to each element of SEQUENCE, presumably for side effects. +Return SEQUENCE." + (mapc function sequence)) + +(defalias 'seq-each #'seq-do) + +(cl-defgeneric seq-p (sequence) + "Return non-nil if SEQUENCE is a sequence, nil otherwise." + (sequencep sequence)) + +(cl-defgeneric seq-copy (sequence) + "Return a shallow copy of SEQUENCE." + (copy-sequence sequence)) + +(cl-defgeneric seq-subseq (sequence start &optional end) + "Return the sequence of elements of SEQUENCE from START to END. +END is inclusive. + +If END is omitted, it defaults to the length of the sequence. If +START or END is negative, it counts from the end. Signal an +error if START or END are outside of the sequence (i.e too large +if positive or too small if negative)." + (cl-subseq sequence start end)) + + +(cl-defgeneric seq-map (function sequence) + "Return the result of applying FUNCTION to each element of SEQUENCE." + (let (result) + (seq-do (lambda (elt) + (push (funcall function elt) result)) + sequence) + (nreverse result))) + +;; faster implementation for sequences (sequencep) +(cl-defmethod seq-map (function (sequence sequence)) + (mapcar function sequence)) + +(cl-defgeneric seq-mapn (function sequence &rest sequences) + "Like `seq-map' but FUNCTION is mapped over all SEQUENCES. +The arity of FUNCTION must match the number of SEQUENCES, and the +mapping stops on the shortest sequence. +Return a list of the results. + +\(fn FUNCTION SEQUENCES...)" + (let ((result nil) + (sequences (seq-map (lambda (s) (seq-into s 'list)) + (cons sequence sequences)))) + (while (not (memq nil sequences)) + (push (apply function (seq-map #'car sequences)) result) + (setq sequences (seq-map #'cdr sequences))) + (nreverse result))) + +(cl-defgeneric seq-drop (sequence n) + "Remove the first N elements of SEQUENCE and return the result. +The result is a sequence of the same type as SEQUENCE. + +If N is a negative integer or zero, SEQUENCE is returned." + (if (<= n 0) + sequence + (let ((length (seq-length sequence))) + (seq-subseq sequence (min n length) length)))) + +(cl-defgeneric seq-take (sequence n) + "Take the first N elements of SEQUENCE and return the result. +The result is a sequence of the same type as SEQUENCE. + +If N is a negative integer or zero, an empty sequence is +returned." + (seq-subseq sequence 0 (min (max n 0) (seq-length sequence)))) + +(cl-defgeneric seq-drop-while (pred sequence) + "Remove the successive elements of SEQUENCE for which PRED returns non-nil. +PRED is a function of one argument. The result is a sequence of +the same type as SEQUENCE." + (seq-drop sequence (seq--count-successive pred sequence))) + +(cl-defgeneric seq-take-while (pred sequence) + "Take the successive elements of SEQUENCE for which PRED returns non-nil. +PRED is a function of one argument. The result is a sequence of +the same type as SEQUENCE." + (seq-take sequence (seq--count-successive pred sequence))) + +(cl-defgeneric seq-empty-p (sequence) + "Return non-nil if the SEQUENCE is empty, nil otherwise." + (= 0 (seq-length sequence))) + +(cl-defgeneric seq-sort (pred sequence) + "Sort SEQUENCE using PRED as comparison function. +The result is a sequence of the same type as SEQUENCE." + (let ((result (seq-sort pred (append sequence nil)))) + (seq-into result (type-of sequence)))) + +(cl-defmethod seq-sort (pred (list list)) + (sort (seq-copy list) pred)) + +(cl-defgeneric seq-reverse (sequence) + "Return a sequence with elements of SEQUENCE in reverse order." + (let ((result '())) + (seq-map (lambda (elt) + (push elt result)) + sequence) + (seq-into result (type-of sequence)))) + +;; faster implementation for sequences (sequencep) +(cl-defmethod seq-reverse ((sequence sequence)) + (reverse sequence)) + +(cl-defgeneric seq-concatenate (type &rest sequences) + "Concatenate SEQUENCES into a single sequence of type TYPE. +TYPE must be one of following symbols: vector, string or list. + +\n(fn TYPE SEQUENCE...)" + (apply #'cl-concatenate type (seq-map #'seq-into-sequence sequences))) + +(cl-defgeneric seq-into-sequence (sequence) + "Convert SEQUENCE into a sequence. + +The default implementation is to signal an error if SEQUENCE is not a +sequence, specific functions should be implemented for new types +of sequence." + (unless (sequencep sequence) + (error "Cannot convert %S into a sequence" sequence)) + sequence) + +(cl-defgeneric seq-into (sequence type) + "Concatenate the elements of SEQUENCE into a sequence of type TYPE. +TYPE can be one of the following symbols: vector, string or +list." + (pcase type + (`vector (vconcat sequence)) + (`string (concat sequence)) + (`list (append sequence nil)) + (_ (error "Not a sequence type name: %S" type)))) + +(cl-defgeneric seq-filter (pred sequence) + "Return a list of all the elements for which (PRED element) is non-nil in SEQUENCE." + (let ((exclude (make-symbol "exclude"))) + (delq exclude (seq-map (lambda (elt) + (if (funcall pred elt) + elt + exclude)) + sequence)))) + +(cl-defgeneric seq-remove (pred sequence) + "Return a list of all the elements for which (PRED element) is nil in SEQUENCE." + (seq-filter (lambda (elt) (not (funcall pred elt))) + sequence)) + +(cl-defgeneric seq-reduce (function sequence initial-value) + "Reduce the function FUNCTION across SEQUENCE, starting with INITIAL-VALUE. + +Return the result of calling FUNCTION with INITIAL-VALUE and the +first element of SEQUENCE, then calling FUNCTION with that result and +the second element of SEQUENCE, then with that result and the third +element of SEQUENCE, etc. + +If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called." + (if (seq-empty-p sequence) + initial-value + (let ((acc initial-value)) + (seq-doseq (elt sequence) + (setq acc (funcall function acc elt))) + acc))) + +(cl-defgeneric seq-every-p (pred sequence) + "Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE." + (catch 'seq--break + (seq-doseq (elt sequence) + (or (funcall pred elt) + (throw 'seq--break nil))) + t)) + +(cl-defgeneric seq-some (pred sequence) + "Return the first value for which if (PRED element) is non-nil for in SEQUENCE." + (catch 'seq--break + (seq-doseq (elt sequence) + (let ((result (funcall pred elt))) + (when result + (throw 'seq--break result)))) + nil)) + +(cl-defgeneric seq-find (pred sequence &optional default) + "Return the first element for which (PRED element) is non-nil in SEQUENCE. +If no element is found, return DEFAULT. + +Note that `seq-find' has an ambiguity if the found element is +identical to DEFAULT, as it cannot be known if an element was +found or not." + (catch 'seq--break + (seq-doseq (elt sequence) + (when (funcall pred elt) + (throw 'seq--break elt))) + default)) + +(cl-defgeneric seq-count (pred sequence) + "Return the number of elements for which (PRED element) is non-nil in SEQUENCE." + (let ((count 0)) + (seq-doseq (elt sequence) + (when (funcall pred elt) + (setq count (+ 1 count)))) + count)) + +(cl-defgeneric seq-contains (sequence elt &optional testfn) + "Return the first element in SEQUENCE that is equal to ELT. +Equality is defined by TESTFN if non-nil or by `equal' if nil." + (seq-some (lambda (e) + (funcall (or testfn #'equal) elt e)) + sequence)) + +(cl-defgeneric seq-position (sequence elt &optional testfn) + "Return the index of the first element in SEQUENCE that is equal to ELT. +Equality is defined by TESTFN if non-nil or by `equal' if nil." + (let ((index 0)) + (catch 'seq--break + (seq-doseq (e sequence) + (when (funcall (or testfn #'equal) e elt) + (throw 'seq--break index)) + (setq index (1+ index))) + nil))) + +(cl-defgeneric seq-uniq (sequence &optional testfn) + "Return a list of the elements of SEQUENCE with duplicates removed. +TESTFN is used to compare elements, or `equal' if TESTFN is nil." + (let ((result '())) + (seq-doseq (elt sequence) + (unless (seq-contains result elt testfn) + (setq result (cons elt result)))) + (nreverse result))) + +(cl-defgeneric seq-mapcat (function sequence &optional type) + "Concatenate the result of applying FUNCTION to each element of SEQUENCE. +The result is a sequence of type TYPE, or a list if TYPE is nil." + (apply #'seq-concatenate (or type 'list) + (seq-map function sequence))) + +(cl-defgeneric seq-partition (sequence n) + "Return a list of the elements of SEQUENCE grouped into sub-sequences of length N. +The last sequence may contain less than N elements. If N is a +negative integer or 0, nil is returned." + (unless (< n 1) + (let ((result '())) + (while (not (seq-empty-p sequence)) + (push (seq-take sequence n) result) + (setq sequence (seq-drop sequence n))) + (nreverse result)))) + +(cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn) + "Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2. +Equality is defined by TESTFN if non-nil or by `equal' if nil." + (seq-reduce (lambda (acc elt) + (if (seq-contains sequence2 elt testfn) + (cons elt acc) + acc)) + (seq-reverse sequence1) + '())) + +(cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn) + "Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2. +Equality is defined by TESTFN if non-nil or by `equal' if nil." + (seq-reduce (lambda (acc elt) + (if (not (seq-contains sequence2 elt testfn)) + (cons elt acc) + acc)) + (seq-reverse sequence1) + '())) + +(cl-defgeneric seq-group-by (function sequence) + "Apply FUNCTION to each element of SEQUENCE. +Separate the elements of SEQUENCE into an alist using the results as +keys. Keys are compared using `equal'." + (seq-reduce + (lambda (acc elt) + (let* ((key (funcall function elt)) + (cell (assoc key acc))) + (if cell + (setcdr cell (push elt (cdr cell))) + (push (list key elt) acc)) + acc)) + (seq-reverse sequence) + nil)) + +(cl-defgeneric seq-min (sequence) + "Return the smallest element of SEQUENCE. +SEQUENCE must be a sequence of numbers or markers." + (apply #'min (seq-into sequence 'list))) + +(cl-defgeneric seq-max (sequence) + "Return the largest element of SEQUENCE. +SEQUENCE must be a sequence of numbers or markers." + (apply #'max (seq-into sequence 'list))) + +(defun seq--count-successive (pred sequence) + "Return the number of successive elements for which (PRED element) is non-nil in SEQUENCE." + (let ((n 0) + (len (seq-length sequence))) + (while (and (< n len) + (funcall pred (seq-elt sequence n))) + (setq n (+ 1 n))) + n)) + +(defun seq--make-pcase-bindings (args) + "Return a list of bindings of the variables in ARGS to the elements of a sequence." + (let ((bindings '()) + (index 0) + (rest-marker nil)) + (seq-doseq (name args) + (unless rest-marker + (pcase name + (`&rest + (progn (push `(app (pcase--flip seq-drop ,index) + ,(seq--elt-safe args (1+ index))) + bindings) + (setq rest-marker t))) + (_ + (push `(app (pcase--flip seq--elt-safe ,index) ,name) bindings)))) + (setq index (1+ index))) + bindings)) + +(defun seq--make-pcase-patterns (args) + "Return a list of `(seq ...)' pcase patterns from the argument list ARGS." + (cons 'seq + (seq-map (lambda (elt) + (if (seq-p elt) + (seq--make-pcase-patterns elt) + elt)) + args))) + +;; TODO: make public? +(defun seq--elt-safe (sequence n) + "Return element of SEQUENCE at the index N. +If no element is found, return nil." + (ignore-errors (seq-elt sequence n))) + + +;;; Optimized implementations for lists + +(cl-defmethod seq-drop ((list list) n) + "Optimized implementation of `seq-drop' for lists." + (while (and list (> n 0)) + (setq list (cdr list) + n (1- n))) + list) + +(cl-defmethod seq-take ((list list) n) + "Optimized implementation of `seq-take' for lists." + (let ((result '())) + (while (and list (> n 0)) + (setq n (1- n)) + (push (pop list) result)) + (nreverse result))) + +(cl-defmethod seq-drop-while (pred (list list)) + "Optimized implementation of `seq-drop-while' for lists." + (while (and list (funcall pred (car list))) + (setq list (cdr list))) + list) + +(cl-defmethod seq-empty-p ((list list)) + "Optimized implementation of `seq-empty-p' for lists." + (null list)) + + +(defun seq--activate-font-lock-keywords () + "Activate font-lock keywords for some symbols defined in seq." + (font-lock-add-keywords 'emacs-lisp-mode + '("\\<seq-doseq\\>" "\\<seq-let\\>"))) + +(unless (fboundp 'elisp--font-lock-flush-elisp-buffers) + ;; In Emacs≥25, (via elisp--font-lock-flush-elisp-buffers and a few others) + ;; we automatically highlight macros. + (add-hook 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords)) + +(provide 'seq) +;;; seq.el ends here diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index d0e3c5763b5..229bb587488 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-2015 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: @@ -68,9 +68,9 @@ This is slower, but filters out some innocuous shadowing." "Return a list of Emacs Lisp files that create shadows. This function does the work for `list-load-path-shadows'. -We traverse PATH looking for shadows, and return a \(possibly empty\) +We traverse PATH looking for shadows, and return a \(possibly empty) even-length list of files. A file in this list at position 2i shadows -the file in position 2i+1. Emacs Lisp file suffixes \(.el and .elc\) +the file in position 2i+1. Emacs Lisp file suffixes \(.el and .elc) are stripped from the file names in the list. See the documentation for `list-load-path-shadows' for further information." @@ -115,7 +115,9 @@ See the documentation for `list-load-path-shadows' for further information." ;; FILE now contains the current file name, with no suffix. (unless (or (member file files-seen-this-dir) ;; Ignore these files. - (member file '("subdirs" "leim-list"))) + (member file (list "subdirs" "leim-list" + (file-name-sans-extension + dir-locals-file)))) ;; File has not been seen yet in this directory. ;; This test prevents us declaring that XXX.el shadows ;; XXX.elc (or vice-versa) when they are in the same directory. @@ -211,7 +213,7 @@ For example, suppose `load-path' is set to 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'). diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index f9d0fd9366b..738bdddcddf 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-2015 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: languages, lisp, internal, parsing, indentation @@ -169,13 +169,13 @@ (cl-incf smie-warning-count)) (puthash key val table)))) -(put 'smie-precs->prec2 'pure t) (defun smie-precs->prec2 (precs) "Compute a 2D precedence table from a list of precedences. PRECS should be a list, sorted by precedence (e.g. \"+\" will come before \"*\"), of elements of the form \(left OP ...) or (right OP ...) or (nonassoc OP ...) or (assoc OP ...). All operators in one of those elements share the same precedence level and associativity." + (declare (pure t)) (let ((prec2-table (make-hash-table :test 'equal))) (dolist (prec precs) (dolist (op (cdr prec)) @@ -193,8 +193,8 @@ one of those elements share the same precedence level and associativity." (smie-set-prec2tab prec2-table other-op op op1))))))) prec2-table)) -(put 'smie-merge-prec2s 'pure t) (defun smie-merge-prec2s (&rest tables) + (declare (pure t)) (if (null (cdr tables)) (car tables) (let ((prec2 (make-hash-table :test 'equal))) @@ -209,11 +209,10 @@ one of those elements share the same precedence level and associativity." table)) prec2))) -(put 'smie-bnf->prec2 'pure t) (defun smie-bnf->prec2 (bnf &rest resolvers) "Convert the BNF grammar into a prec2 table. BNF is a list of nonterminal definitions of the form: - \(NONTERM RHS1 RHS2 ...) + (NONTERM RHS1 RHS2 ...) where each RHS is a (non-empty) list of terminals (aka tokens) or non-terminals. Not all grammars are accepted: - an RHS cannot be an empty list (this is not needed, since SMIE allows all @@ -232,6 +231,7 @@ Conflicts can be resolved via RESOLVERS, which is a list of elements that can be either: - a precs table (see `smie-precs->prec2') to resolve conflicting constraints, - a constraint (T1 REL T2) where REL is one of = < or >." + (declare (pure t)) ;; FIXME: Add repetition operator like (repeat <separator> <elems>). ;; Maybe also add (or <elem1> <elem2>...) for things like ;; (exp (exp (or "+" "*" "=" ..) exp)). @@ -503,11 +503,11 @@ CSTS is a list of pairs representing arcs in a graph." ;; (t (cl-assert (eq v '=)))))))) ;; prec2)) -(put 'smie-prec2->grammar 'pure t) (defun smie-prec2->grammar (prec2) "Take a 2D precedence table and turn it into an alist of precedence levels. PREC2 is a table as returned by `smie-precs->prec2' or `smie-bnf->prec2'." + (declare (pure t)) ;; For each operator, we create two "variables" (corresponding to ;; the left and right precedence level), which are represented by ;; cons cells. Those are the very cons cells that appear in the @@ -612,8 +612,11 @@ PREC2 is a table as returned by `smie-precs->prec2' or (cons (pcase (cdr x) (`closer (cddr (assoc token table))) (`opener (cdr (assoc token table)))))) - (cl-assert (numberp (car cons))) - (setf (car cons) (list (car cons))))) + ;; `cons' can be nil for openers/closers which only contain + ;; "atomic" elements. + (when cons + (cl-assert (numberp (car cons))) + (setf (car cons) (list (car cons)))))) (let ((ca (gethash :smie-closer-alist prec2))) (when ca (push (cons :smie-closer-alist ca) table))) ;; (smie-check-grammar table prec2 'step3) @@ -632,14 +635,14 @@ e.g. a LEFT-LEVEL of nil means this is a token that behaves somewhat like an open-paren, whereas a RIGHT-LEVEL of nil would correspond to something like a close-paren.") -(defvar smie-forward-token-function 'smie-default-forward-token +(defvar smie-forward-token-function #'smie-default-forward-token "Function to scan forward for the next token. Called with no argument should return a token and move to its end. If no token is found, return nil or the empty string. It can return nil when bumping into a parenthesis, which lets SMIE use syntax-tables to handle them in efficient C code.") -(defvar smie-backward-token-function 'smie-default-backward-token +(defvar smie-backward-token-function #'smie-default-backward-token "Function to scan backward the previous token. Same calling convention as `smie-forward-token-function' except it should move backward to the beginning of the previous token.") @@ -707,13 +710,16 @@ 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* ((epos1 (nth 2 err)) + (epos (if (<= (point) epos1) (nth 3 err) epos1))) + (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)))))) @@ -803,9 +809,9 @@ Possible return values: nil: we skipped over an identifier, matched parentheses, ..." (smie-next-sexp (indirect-function smie-backward-token-function) - (indirect-function 'backward-sexp) - (indirect-function 'smie-op-left) - (indirect-function 'smie-op-right) + (indirect-function #'backward-sexp) + (indirect-function #'smie-op-left) + (indirect-function #'smie-op-right) halfsexp)) (defun smie-forward-sexp (&optional halfsexp) @@ -824,19 +830,19 @@ Possible return values: nil: we skipped over an identifier, matched parentheses, ..." (smie-next-sexp (indirect-function smie-forward-token-function) - (indirect-function 'forward-sexp) - (indirect-function 'smie-op-right) - (indirect-function 'smie-op-left) + (indirect-function #'forward-sexp) + (indirect-function #'smie-op-right) + (indirect-function #'smie-op-left) halfsexp)) ;;; Miscellaneous commands using the precedence parser. -(defun smie-backward-sexp-command (&optional n) +(defun smie-backward-sexp-command (n) "Move backward through N logical elements." (interactive "^p") (smie-forward-sexp-command (- n))) -(defun smie-forward-sexp-command (&optional n) +(defun smie-forward-sexp-command (n) "Move forward through N logical elements." (interactive "^p") (let ((forw (> n 0)) @@ -1060,10 +1066,12 @@ OPENER is non-nil if TOKEN is an opener and nil if it's a closer." (defun smie--matching-block-data (orig &rest args) "A function suitable for `show-paren-data-function' (which see)." (if (or (null smie-closer-alist) - (eq (point) (car smie--matching-block-data-cache))) + (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 (point))) + (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))) @@ -1106,7 +1114,7 @@ OPENER is non-nil if TOKEN is an opener and nil if it's a closer." (nth 1 there) (nth 2 there) (not (nth 0 there))))))) (scan-error nil)) - (goto-char (car smie--matching-block-data-cache))) + (goto-char (caar smie--matching-block-data-cache))) (apply #'smie--matching-block-data orig args))) ;;; The indentation engine. @@ -1116,7 +1124,7 @@ OPENER is non-nil if TOKEN is an opener and nil if it's a closer." :type 'integer :group 'smie) -(defvar smie-rules-function 'ignore +(defvar smie-rules-function #'ignore "Function providing the indentation rules. It takes two arguments METHOD and ARG where the meaning of ARG and the expected return value depends on METHOD. @@ -1128,9 +1136,15 @@ METHOD can be: - :elem, in which case the function should return either: - the offset to use to indent function arguments (ARG = `arg') - the basic indentation step (ARG = `basic'). + - the token to use (when ARG = `empty-line-token') when we don't know how + to indent an empty line. - :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 @@ -1146,6 +1160,15 @@ NUMBER offset by NUMBER, relative to a base token The functions whose name starts with \"smie-rule-\" are helper functions designed specifically for use in this function.") +(defvar smie--hanging-eolp-function + ;; FIXME: This is a quick hack for 24.4. Don't document it and replace with + ;; a well-defined function with a cleaner interface instead! + (lambda () + (skip-chars-forward " \t") + (or (eolp) + (and ;; (looking-at comment-start-skip) ;(bug#16041). + (forward-comment (point-max)))))) + (defalias 'smie-rule-hanging-p 'smie-indent--hanging-p) (defun smie-indent--hanging-p () "Return non-nil if the current token is \"hanging\". @@ -1159,10 +1182,7 @@ the beginning of a line." (not (eobp)) ;; Could be an open-paren. (forward-char 1)) - (skip-chars-forward " \t") - (or (eolp) - (and (looking-at comment-start-skip) - (forward-comment (point-max)))) + (funcall smie--hanging-eolp-function) (point)))))) (defalias 'smie-rule-bolp 'smie-indent--bolp) @@ -1180,6 +1200,21 @@ Comments are treated as spaces." (forward-comment (- (point))) (<= (point) bol)))) +(defun smie-indent--current-column () + "Like `current-column', but if there's a comment before us, use that." + ;; This is used, so that when we align elements, we don't get + ;; toto = { /* foo, */ a, + ;; b } + ;; but + ;; toto = { /* foo, */ a, + ;; b } + (let ((pos (point)) + (lbp (line-beginning-position))) + (save-excursion + (unless (and (forward-comment -1) (>= (point) lbp)) + (goto-char pos)) + (current-column)))) + ;; Dynamically scoped. (defvar smie--parent) (defvar smie--after) (defvar smie--token) @@ -1232,14 +1267,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) @@ -1319,8 +1347,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." @@ -1333,11 +1361,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)) @@ -1358,6 +1382,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))) @@ -1365,9 +1395,9 @@ 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)) + (cons (buffer-substring-no-properties (1- (point)) (point)) (if (match-end 1) '(0 nil) '(nil 0)))) - ((looking-at "\\s\"") + ((looking-at "\\s\"\\|\\s|") (forward-sexp 1) nil) ((eobp) nil) @@ -1382,9 +1412,9 @@ 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))) + (cons (buffer-substring-no-properties (point) (1+ (point))) (if (eq class 4) '(nil 0) '(0 nil)))) - ((eq class 7) + ((memq class '(7 15)) (backward-sexp 1) nil) ((bobp) nil) @@ -1426,8 +1456,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) @@ -1559,7 +1594,9 @@ should not be computed on the basis of the following token." ;; So we use a heuristic here, which is that we only use virtual ;; if the parent is tightly linked to the child token (they're ;; part of the same BNF rule). - (if (car parent) (current-column) (smie-indent-virtual))))))))))) + (if (car parent) + (smie-indent--current-column) + (smie-indent-virtual))))))))))) (defun smie-indent-comment () "Compute indentation of a comment." @@ -1651,6 +1688,19 @@ should not be computed on the basis of the following token." (+ (smie-indent-virtual) (smie-indent--offset 'basic))) ; (t (smie-indent-virtual)))))) ;An infix. +(defun smie-indent-empty-line () + "Indentation rule when there's nothing yet on the line." + ;; Without this rule, SMIE assumes that an empty line will be filled with an + ;; argument (since it falls back to smie-indent-sexps), which tends + ;; to indent far too deeply. + (when (eolp) + (let ((token (or (funcall smie-rules-function :elem 'empty-line-token) + ;; FIXME: Should we default to ";"? + ;; ";" + ))) + (when (assoc token smie-grammar) + (smie-indent-keyword token))))) + (defun smie-indent-exps () ;; Indentation of sequences of simple expressions without ;; intervening keywords or operators. E.g. "a b c" or "g (balbla) f". @@ -1689,12 +1739,12 @@ should not be computed on the basis of the following token." ;; There's a previous element, and it's not special (it's not ;; the function), so let's just align with that one. (goto-char (car positions)) - (current-column)) + (smie-indent--current-column)) ((cdr positions) ;; We skipped some args plus the function and bumped into something. ;; Align with the first arg. (goto-char (cadr positions)) - (current-column)) + (smie-indent--current-column)) (positions ;; We're the first arg. (goto-char (car positions)) @@ -1702,14 +1752,14 @@ should not be computed on the basis of the following token." ;; We used to use (smie-indent-virtual), but that ;; doesn't seem right since it might then indent args less than ;; the function itself. - (current-column))))))) + (smie-indent--current-column))))))) (defvar smie-indent-functions '(smie-indent-fixindent smie-indent-bob smie-indent-close smie-indent-comment smie-indent-comment-continue smie-indent-comment-close smie-indent-comment-inside smie-indent-inside-string smie-indent-keyword smie-indent-after-keyword - smie-indent-exps) + smie-indent-empty-line smie-indent-exps) "Functions to compute the indentation. Each function is called with no argument, shouldn't move point, and should return either nil if it has no opinion, or an integer representing the column @@ -1824,6 +1874,375 @@ KEYWORDS are additional arguments, which can use the following keywords: (append smie-blink-matching-triggers (delete-dups triggers))))))) +(declare-function edebug-instrument-function "edebug" (func)) + +(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. + (prog1 + (smie-config--guess-1 sigs) + (message "Guessing...done"))))) + +(defun smie-config--guess-1 (sigs) + (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)))))))))) + rules)) + +(defun smie-config-guess () + "Try and figure out this buffer's indentation settings. +To save the result for future sessions, use `smie-config-save'." + (interactive) + (if (eq smie-grammar 'unset) + (user-error "This buffer does not seem to be using SMIE")) + (let ((config (smie-config--guess (point-min) (point-max)))) + (cond + ((null config) (message "Nothing to change")) + ((null smie-config--buffer-local) + (smie-config-local config) + (message "Local rules set")) + ((y-or-n-p "Replace existing local config? ") + (message "Local rules replaced") + (smie-config-local config)) + ((y-or-n-p "Merge with existing local config? ") + (message "Local rules adjusted") + (smie-config-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. +One way to generate local rules is the command `smie-config-guess'." + (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..e6d451ac62e --- /dev/null +++ b/lisp/emacs-lisp/subr-x.el @@ -0,0 +1,203 @@ +;;; subr-x.el --- extra Lisp functions -*- lexical-binding:t -*- + +;; Copyright (C) 2013-2015 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: + +(require 'pcase) + + +(defmacro internal--thread-argument (first? &rest forms) + "Internal implementation for `thread-first' and `thread-last'. +When Argument FIRST? is non-nil argument is threaded first, else +last. FORMS are the expressions to be threaded." + (pcase forms + (`(,x (,f . ,args) . ,rest) + `(internal--thread-argument + ,first? ,(if first? `(,f ,x ,@args) `(,f ,@args ,x)) ,@rest)) + (`(,x ,f . ,rest) `(internal--thread-argument ,first? (,f ,x) ,@rest)) + (_ (car forms)))) + +(defmacro thread-first (&rest forms) + "Thread FORMS elements as the first argument of their successor. +Example: + (thread-first + 5 + (+ 20) + (/ 25) + - + (+ 40)) +Is equivalent to: + (+ (- (/ (+ 5 20) 25)) 40) +Note how the single `-' got converted into a list before +threading." + (declare (indent 1) + (debug (form &rest [&or symbolp (sexp &rest form)]))) + `(internal--thread-argument t ,@forms)) + +(defmacro thread-last (&rest forms) + "Thread FORMS elements as the last argument of their successor. +Example: + (thread-last + 5 + (+ 20) + (/ 25) + - + (+ 40)) +Is equivalent to: + (+ 40 (- (/ 25 (+ 20 5)))) +Note how the single `-' got converted into a list before +threading." + (declare (indent 1) (debug thread-first)) + `(internal--thread-argument nil ,@forms)) + +(defsubst internal--listify (elt) + "Wrap ELT in a list if it is not one." + (if (not (listp elt)) + (list elt) + elt)) + +(defsubst internal--check-binding (binding) + "Check BINDING is properly formed." + (when (> (length binding) 2) + (signal + 'error + (cons "`let' bindings can have only one value-form" binding))) + binding) + +(defsubst internal--build-binding-value-form (binding prev-var) + "Build the conditional value form for BINDING using PREV-VAR." + `(,(car binding) (and ,prev-var ,(cadr binding)))) + +(defun internal--build-binding (binding prev-var) + "Check and build a single BINDING with PREV-VAR." + (thread-first + binding + internal--listify + internal--check-binding + (internal--build-binding-value-form prev-var))) + +(defun internal--build-bindings (bindings) + "Check and build conditional value forms for BINDINGS." + (let ((prev-var t)) + (mapcar (lambda (binding) + (let ((binding (internal--build-binding binding prev-var))) + (setq prev-var (car binding)) + binding)) + bindings))) + +(defmacro if-let (bindings then &rest else) + "Process BINDINGS and if all values are non-nil eval THEN, else ELSE. +Argument BINDINGS is a list of tuples whose car is a symbol to be +bound and (optionally) used in THEN, and its cadr is a sexp to be +evalled to set symbol's value. In the special case you only want +to bind a single value, BINDINGS can just be a plain tuple." + (declare (indent 2) + (debug ([&or (&rest (symbolp form)) (symbolp form)] form body))) + (when (and (<= (length bindings) 2) + (not (listp (car bindings)))) + ;; Adjust the single binding case + (setq bindings (list bindings))) + `(let* ,(internal--build-bindings bindings) + (if ,(car (internal--listify (car (last bindings)))) + ,then + ,@else))) + +(defmacro when-let (bindings &rest body) + "Process BINDINGS and if all values are non-nil eval BODY. +Argument BINDINGS is a list of tuples whose car is a symbol to be +bound and (optionally) used in BODY, and its cadr is a sexp to be +evalled to set symbol's value. In the special case you only want +to bind a single value, BINDINGS can just be a plain tuple." + (declare (indent 1) (debug if-let)) + (list 'if-let bindings (macroexp-progn body))) + +(defsubst hash-table-empty-p (hash-table) + "Check whether HASH-TABLE is empty (has 0 elements)." + (zerop (hash-table-count hash-table))) + +(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)) + +(define-obsolete-function-alias 'string-reverse 'reverse "25.1") + +(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 3e850320133..d446a2c0af7 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-2015 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal ;; This file is part of GNU Emacs. @@ -43,8 +43,6 @@ (eval-when-compile (require 'cl-lib)) -(defvar font-lock-beginning-of-syntax-function) - ;;; Applying syntax-table properties where needed. (defvar syntax-propertize-function nil @@ -106,10 +104,6 @@ Put first the functions more likely to cause a change and cheaper to compute.") (point-max)))) (cons beg end)) -(defvar syntax-propertize--done -1 - "Position up to which syntax-table properties have been set.") -(make-variable-buffer-local 'syntax-propertize--done) - (defun syntax-propertize--shift-groups (re n) (replace-regexp-in-string "\\\\(\\?\\([0-9]+\\):" @@ -290,39 +284,60 @@ The return value is a function suitable for `syntax-propertize-function'." (defun syntax-propertize (pos) "Ensure that syntax-table properties are set until POS." - (when (and syntax-propertize-function - (< syntax-propertize--done pos)) - ;; (message "Needs to syntax-propertize from %s to %s" - ;; syntax-propertize--done pos) - (set (make-local-variable 'parse-sexp-lookup-properties) t) - (save-excursion - (with-silent-modifications - (let* ((start (max syntax-propertize--done (point-min))) - (end (max pos - (min (point-max) - (+ start syntax-propertize-chunk-size)))) - (funs syntax-propertize-extend-region-functions)) - (while funs - (let ((new (funcall (pop funs) start end))) - (if (or (null new) - (and (>= (car new) start) (<= (cdr new) end))) - nil - (setq start (car new)) - (setq end (cdr new)) - ;; If there's been a change, we should go through the - ;; list again since this new position may - ;; warrant a different answer from one of the funs we've - ;; already seen. - (unless (eq funs - (cdr syntax-propertize-extend-region-functions)) - (setq funs syntax-propertize-extend-region-functions))))) - ;; Move the limit before calling the function, so the function - ;; can use syntax-ppss. - (setq syntax-propertize--done end) - ;; (message "syntax-propertizing from %s to %s" start end) - (remove-text-properties start end - '(syntax-table nil syntax-multiline nil)) - (funcall syntax-propertize-function start end)))))) + (when (< syntax-propertize--done pos) + (if (null syntax-propertize-function) + (setq syntax-propertize--done (max (point-max) pos)) + ;; (message "Needs to syntax-propertize from %s to %s" + ;; syntax-propertize--done pos) + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (save-excursion + (with-silent-modifications + (make-local-variable 'syntax-propertize--done) ;Just in case! + (let* ((start (max (min syntax-propertize--done (point-max)) + (point-min))) + (end (max pos + (min (point-max) + (+ start syntax-propertize-chunk-size)))) + (funs syntax-propertize-extend-region-functions)) + (while funs + (let ((new (funcall (pop funs) start end)) + ;; Avoid recursion! + (syntax-propertize--done most-positive-fixnum)) + (if (or (null new) + (and (>= (car new) start) (<= (cdr new) end))) + nil + (setq start (car new)) + (setq end (cdr new)) + ;; If there's been a change, we should go through the + ;; list again since this new position may + ;; warrant a different answer from one of the funs we've + ;; already seen. + (unless (eq funs + (cdr syntax-propertize-extend-region-functions)) + (setq funs syntax-propertize-extend-region-functions))))) + ;; Move the limit before calling the function, so the function + ;; can use syntax-ppss. + (setq syntax-propertize--done end) + ;; (message "syntax-propertizing from %s to %s" start end) + (remove-text-properties start end + '(syntax-table nil syntax-multiline nil)) + ;; Avoid recursion! + (let ((syntax-propertize--done most-positive-fixnum)) + (funcall syntax-propertize-function start end)))))))) + +;;; Link syntax-propertize with syntax.c. + +(defvar syntax-propertize-chunks + ;; We're not sure how far we'll go. In my tests, using chunks of 2000 + ;; brings to overhead to something negligible. Passing ‘charpos’ directly + ;; also works (basically works line-by-line) but results in an overhead which + ;; I thought was a bit too high (like around 50%). + 2000) + +(defun internal--syntax-propertize (charpos) + ;; FIXME: Called directly from C. + (save-match-data + (syntax-propertize (min (+ syntax-propertize-chunks charpos) (point-max))))) ;;; Incrementally compute and memoize parser state. @@ -360,13 +375,12 @@ from each other, to avoid keeping too much useless info.") "Function to move back outside of any comment/string/paren. This function should move the cursor back to some syntactically safe point (where the PPSS is equivalent to nil).") +(make-obsolete-variable 'syntax-begin-function nil "25.1") -(defvar syntax-ppss-cache nil +(defvar-local syntax-ppss-cache nil "List of (POS . PPSS) pairs, in decreasing POS order.") -(make-variable-buffer-local 'syntax-ppss-cache) -(defvar syntax-ppss-last nil +(defvar-local syntax-ppss-last nil "Cache of (LAST-POS . LAST-PPSS).") -(make-variable-buffer-local 'syntax-ppss-last) (defalias 'syntax-ppss-after-change-function 'syntax-ppss-flush-cache) (defun syntax-ppss-flush-cache (beg &rest ignored) @@ -405,9 +419,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) @@ -482,11 +501,6 @@ Point is at POS when this function returns." ;; - The function might be slow. ;; - If this function almost always finds a safe nearby spot, ;; the cache won't be populated, so consulting it is cheap. - (when (and (not syntax-begin-function) - (boundp 'font-lock-beginning-of-syntax-function) - font-lock-beginning-of-syntax-function) - (set (make-local-variable 'syntax-begin-function) - font-lock-beginning-of-syntax-function)) (when (and syntax-begin-function (progn (goto-char pos) (funcall syntax-begin-function) @@ -569,7 +583,7 @@ Point is at POS when this function returns." ;; (defun buffer-syntactic-context (&optional buffer) ;; "Syntactic context at point in BUFFER. -;; Either of `string', `comment' or `nil'. +;; Either of `string', `comment' or nil. ;; This is an XEmacs compatibility function." ;; (with-current-buffer (or buffer (current-buffer)) ;; (syntax-ppss-context (syntax-ppss)))) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 9c5115bcd7b..4bd8a19937d 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -1,6 +1,6 @@ ;;; tabulated-list.el --- generic major mode for tabulated lists -*- lexical-binding: t -*- -;; Copyright (C) 2011-2013 Free Software Foundation, Inc. +;; Copyright (C) 2011-2015 Free Software Foundation, Inc. ;; Author: Chong Yidong <cyd@stupidchicken.com> ;; Keywords: extensions, lisp @@ -179,7 +179,9 @@ If ADVANCE is non-nil, move forward by one line afterwards." table) "The `glyphless-char-display' table in Tabulated List buffers.") -(defvar tabulated-list--header-string nil) +(defvar tabulated-list--header-string nil + "Holds the header if `tabulated-list-use-header-line' is nil. +Populated by `tabulated-list-init-header'.") (defvar tabulated-list--header-overlay nil) (defun tabulated-list-init-header () @@ -243,15 +245,17 @@ If ADVANCE is non-nil, move forward by one line afterwards." (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." - (goto-char (point-min)) - (let ((inhibit-read-only t)) - (insert tabulated-list--header-string "\n") - (if tabulated-list--header-overlay - (move-overlay tabulated-list--header-overlay (point-min) (point)) - (setq-local tabulated-list--header-overlay - (make-overlay (point-min) (point)))) - (overlay-put tabulated-list--header-overlay 'face 'underline))) + "Insert a fake Tabulated List \"header line\" at the start of the buffer. +Do nothing if `tabulated-list--header-string' is nil." + (when tabulated-list--header-string + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (insert tabulated-list--header-string "\n") + (if tabulated-list--header-overlay + (move-overlay tabulated-list--header-overlay (point-min) (point)) + (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) "The `revert-buffer-function' for `tabulated-list-mode'. @@ -273,57 +277,105 @@ It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'." (or found (error "No column named %s" name)))) -(defun tabulated-list-print (&optional remember-pos) +(defun tabulated-list--get-sorter () + "Return a sorting predicate for the current tabulated-list. +Return nil if `tabulated-list-sort-key' specifies an unsortable +column. Negate the predicate that would be returned if +`tabulated-list-sort-key' has a non-nil cdr." + (when (and tabulated-list-sort-key + (car tabulated-list-sort-key)) + (let* ((sort-column (car tabulated-list-sort-key)) + (n (tabulated-list--column-number sort-column)) + (sorter (nth 2 (aref tabulated-list-format n)))) + (when (eq sorter t); Default sorter checks column N: + (setq sorter (lambda (A B) + (let ((a (aref (cadr A) n)) + (b (aref (cadr B) n))) + (string< (if (stringp a) a (car a)) + (if (stringp b) b (car b))))))) + ;; Reversed order. + (if (cdr tabulated-list-sort-key) + (lambda (a b) (not (funcall sorter a b))) + sorter)))) + +(defun tabulated-list-print (&optional remember-pos update) "Populate the current Tabulated List mode buffer. This sorts the `tabulated-list-entries' list if sorting is specified by `tabulated-list-sort-key'. It then erases the buffer and inserts the entries with `tabulated-list-printer'. Optional argument REMEMBER-POS, if non-nil, means to move point -to the entry with the same ID element as the current line." +to the entry with the same ID element as the current line and +recenter window line accordingly. + +Non-nil UPDATE argument means to use an alternative printing +method which is faster if most entries haven't changed since the +last print. The only difference in outcome is that tags will not +be removed from entries that haven't changed (see +`tabulated-list-put-tag'). Don't use this immediately after +changing `tabulated-list-sort-key'." (let ((inhibit-read-only t) (entries (if (functionp tabulated-list-entries) (funcall tabulated-list-entries) tabulated-list-entries)) - entry-id saved-pt saved-col) + (sorter (tabulated-list--get-sorter)) + entry-id saved-pt saved-col window-line) (and remember-pos (setq entry-id (tabulated-list-get-id)) - (setq saved-col (current-column))) - (erase-buffer) - (unless tabulated-list-use-header-line - (tabulated-list-print-fake-header)) + (setq saved-col (current-column)) + (when (eq (window-buffer) (current-buffer)) + (setq window-line + (count-screen-lines (window-start) (point))))) ;; Sort the entries, if necessary. - (when (and tabulated-list-sort-key - (car tabulated-list-sort-key)) - (let* ((sort-column (car tabulated-list-sort-key)) - (n (tabulated-list--column-number sort-column)) - (sorter (nth 2 (aref tabulated-list-format n)))) - ;; Is the specified column sortable? - (when sorter - (when (eq sorter t) - (setq sorter ; Default sorter checks column N: - (lambda (A B) - (setq A (aref (cadr A) n)) - (setq B (aref (cadr B) n)) - (string< (if (stringp A) A (car A)) - (if (stringp B) B (car B)))))) - (setq entries (sort entries sorter)) - (if (cdr tabulated-list-sort-key) - (setq entries (nreverse entries))) - (unless (functionp tabulated-list-entries) - (setq tabulated-list-entries entries))))) - ;; Print the resulting list. + (when sorter + (setq entries (sort entries sorter))) + (unless (functionp tabulated-list-entries) + (setq tabulated-list-entries entries)) + ;; Without a sorter, we have no way to just update. + (when (and update (not sorter)) + (setq update nil)) + (if update (goto-char (point-min)) + ;; Redo the buffer, unless we're just updating. + (erase-buffer) + (unless tabulated-list-use-header-line + (tabulated-list-print-fake-header))) + ;; Finally, print the resulting list. (dolist (elt entries) - (and entry-id - (equal entry-id (car elt)) - (setq saved-pt (point))) - (apply tabulated-list-printer elt)) + (let ((id (car elt))) + (and entry-id + (equal entry-id id) + (setq entry-id nil + saved-pt (point))) + ;; If the buffer this empty, simply print each elt. + (if (or (not update) (eobp)) + (apply tabulated-list-printer elt) + (while (let ((local-id (tabulated-list-get-id))) + ;; If we find id, then nothing to update. + (cond ((equal id local-id) + (forward-line 1) + nil) + ;; If this entry sorts after id (or it's the + ;; end), then just insert id and move on. + ((or (not local-id) + (funcall sorter elt + ;; FIXME: Might be faster if + ;; don't construct this list. + (list local-id (tabulated-list-get-entry)))) + (apply tabulated-list-printer elt) + nil) + ;; We find an entry that sorts before id, + ;; it needs to be deleted. + (t t))) + (let ((old (point))) + (forward-line 1) + (delete-region old (point))))))) (set-buffer-modified-p nil) ;; If REMEMBER-POS was specified, move to the "old" location. (if saved-pt (progn (goto-char saved-pt) (move-to-column saved-col) - (recenter)) + (when window-line + (recenter window-line))) (goto-char (point-min))))) (defun tabulated-list-print-entry (id cols) @@ -340,8 +392,10 @@ of column descriptors." (dotimes (n ncols) (setq x (tabulated-list-print-col n (aref cols n) x))) (insert ?\n) - (put-text-property beg (point) 'tabulated-list-id id) - (put-text-property beg (point) 'tabulated-list-entry cols))) + ;; Ever so slightly faster than calling `put-text-property' twice. + (add-text-properties + beg (point) + `(tabulated-list-id ,id tabulated-list-entry ,cols)))) (defun tabulated-list-print-col (n col-desc x) "Insert a specified Tabulated List entry at point. @@ -466,7 +520,9 @@ With a numeric prefix argument N, sort the Nth column." (car (aref tabulated-list-format n)) (get-text-property (point) 'tabulated-list-column-name)))) - (tabulated-list--sort-by-column-name name))) + (if (nth 2 (assoc name (append tabulated-list-format nil))) + (tabulated-list--sort-by-column-name name) + (user-error "Cannot sort by %s" name)))) (defun tabulated-list--sort-by-column-name (name) (when (and name (derived-mode-p 'tabulated-list-mode)) @@ -518,14 +574,13 @@ as the ewoc pretty-printer." (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)) + (setq-local glyphless-char-display tabulated-list-glyphless-char-display) + ;; Avoid messing up the entries' display just because the first + ;; column of the first entry happens to begin with a R2L letter. + (setq bidi-paragraph-direction 'left-to-right)) (put 'tabulated-list-mode 'mode-class 'special) (provide 'tabulated-list) -;; Local Variables: -;; coding: utf-8 -;; End: - ;;; tabulated-list.el ends here diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index 02023b957a5..61a21dc74fd 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-2015 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..c683826535b 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-2015 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 a5619583145..110c63f777a 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -1,6 +1,6 @@ -;;;; testcover.el -- Visual code-coverage tool +;;;; testcover.el -- Visual code-coverage tool -*- lexical-binding:t -*- -;; Copyright (C) 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2015 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> @@ -146,7 +146,8 @@ call to one of the `testcover-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"))) @@ -190,8 +191,9 @@ problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is non-nil, byte-compiles each function after instrumenting." (interactive "fStart covering file: ") (let ((buf (find-file filename)) - (load-read-function 'testcover-read) - (edebug-all-defs t)) + (load-read-function load-read-function)) + (add-function :around load-read-function + #'testcover--read) (setq edebug-form-data nil testcover-module-constants nil testcover-module-1value-functions nil) @@ -206,22 +208,26 @@ non-nil, byte-compiles each function after instrumenting." (defun testcover-this-defun () "Start coverage on function under point." (interactive) - (let* ((edebug-all-defs t) - (x (symbol-function (eval-defun nil)))) + (let ((x (let ((edebug-all-defs t)) + (symbol-function (eval-defun nil))))) (testcover-reinstrument x) x)) -(defun testcover-read (&optional stream) +(defun testcover--read (orig &optional stream) "Read a form using edebug, changing edebug callbacks to testcover callbacks." - (let ((x (edebug-read stream))) - (testcover-reinstrument x) - x)) + (or stream (setq stream standard-input)) + (if (eq stream (current-buffer)) + (let ((x (let ((edebug-all-defs t)) + (edebug-read-and-maybe-wrap-form)))) + (testcover-reinstrument x) + x) + (funcall (or orig #'read) stream))) (defun testcover-reinstrument (form) "Reinstruments FORM to use testcover instead of edebug. This function modifies the list that FORM points to. Result is nil if FORM should return multiple values, t if should always return same -value, 'maybe if either is acceptable." +value, `maybe' if either is acceptable." (let ((fun (car-safe form)) id val) (cond @@ -494,7 +500,7 @@ eliminated by adding more test cases." (len (length points)) (changed (buffer-modified-p)) (coverage (get def 'edebug-coverage)) - ov j item) + ov j) (or (and def-mark points coverage) (error "Missing edebug data for function %s" def)) (when (> len 0) diff --git a/lisp/emacs-lisp/thunk.el b/lisp/emacs-lisp/thunk.el new file mode 100644 index 00000000000..0c5816a616d --- /dev/null +++ b/lisp/emacs-lisp/thunk.el @@ -0,0 +1,74 @@ +;;; thunk.el --- Lazy form evaluation -*- lexical-binding: t -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Nicolas Petton <nicolas@petton.fr> +;; Keywords: sequences +;; Version: 1.0 +;; Package: thunk + +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Thunk provides functions and macros to delay the evaluation of +;; forms. +;; +;; Use `thunk-delay' to delay the evaluation of a form, and +;; `thunk-force' to evaluate it. The result of the evaluation is +;; cached, and only happens once. +;; +;; Here is an example of a form which evaluation is delayed: +;; +;; (setq delayed (thunk-delay (message "this message is delayed"))) +;; +;; `delayed' is not evaluated until `thunk-force' is called, like the +;; following: +;; +;; (thunk-force delayed) + +;; Tests are located at test/automated/thunk-tests.el + +;;; Code: + +(defmacro thunk-delay (&rest body) + "Delay the evaluation of BODY." + (declare (debug t)) + (let ((forced (make-symbol "forced")) + (val (make-symbol "val"))) + `(let (,forced ,val) + (lambda (&optional check) + (if check + ,forced + (unless ,forced + (setf ,val (progn ,@body)) + (setf ,forced t)) + ,val))))) + +(defun thunk-force (delayed) + "Force the evaluation of DELAYED. +The result is cached and will be returned on subsequent calls +with the same DELAYED argument." + (funcall delayed)) + +(defun thunk-evaluated-p (delayed) + "Return non-nil if DELAYED has been evaluated." + (funcall delayed t)) + +(provide 'thunk) +;;; thunk.el ends here diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 1ee3cec15a6..c9e3fbe4f7d 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-2015 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Package: emacs ;; This file is part of GNU Emacs. @@ -125,9 +125,7 @@ of SECS seconds since the epoch. SECS may be a fraction." "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) - (seconds-to-time secs) - (list (floor secs 65536) (mod secs 65536))))) + (let ((delta secs)) (if (or usecs psecs) (setq delta (time-add delta (list 0 0 (or usecs 0) (or psecs 0))))) (time-add time delta))) @@ -207,7 +205,7 @@ timers). If nil, allocate a new cell." "Insert TIMER into `timer-idle-list'. This arranges to activate TIMER whenever Emacs is next idle. If optional argument DONT-WAIT is non-nil, set TIMER to activate -immediately \(see below\), or at the right time, if Emacs is +immediately \(see below), or at the right time, if Emacs is already idle. REUSE-CELL, if non-nil, is a cons cell to reuse when inserting @@ -290,42 +288,51 @@ This function is called, by name, directly by the C code." (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))))) + ;; If `cell' is nil, it means the timer was already canceled, so we + ;; shouldn't be running it at all. This can happen for example with the + ;; following scenario (bug#17392): + ;; - we run timers, starting with A (and remembering the rest as (B C)). + ;; - A runs and a does a sit-for. + ;; - during sit-for we run timer D which cancels timer B. + ;; - timer A finally finishes, so we move on to timers B and C. + (when cell + ;; 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 nil))) + (let ((repeats (/ (timer-until timer nil) + (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-message " `%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) @@ -338,18 +345,26 @@ This function is called, by name, directly by the C code." (defun run-at-time (time repeat function &rest args) "Perform an action at time TIME. Repeat the action every REPEAT seconds, if REPEAT is non-nil. -TIME should be one of: a string giving an absolute time like -\"11:23pm\" (the acceptable formats are those recognized by -`diary-entry-time'; note that such times are interpreted as times -today, even if in the past); a string giving a relative time like -\"2 hours 35 minutes\" (the acceptable formats are those -recognized by `timer-duration'); nil meaning now; a number of -seconds from now; a value from `encode-time'; or t (with non-nil -REPEAT) meaning the next integral multiple of REPEAT. REPEAT may -be an integer or floating point number. The action is to call -FUNCTION with arguments ARGS. +REPEAT may be an integer or floating point number. +TIME should be one of: +- a string giving today's time like \"11:23pm\" + (the acceptable formats are HHMM, H:MM, HH:MM, HHam, HHAM, + HHpm, HHPM, HH:MMam, HH:MMAM, HH:MMpm, or HH:MMPM; + a period `.' can be used instead of a colon `:' to separate + the hour and minute parts); +- a string giving a relative time like \"90\" or \"2 hours 35 minutes\" + (the acceptable forms are a number of seconds without units + or some combination of values using units in `timer-duration-words'); +- nil, meaning now; +- a number of seconds from now; +- a value from `encode-time'; +- or t (with non-nil REPEAT) meaning the next integral + multiple of REPEAT. -This function returns a timer object which you can use in `cancel-timer'." +The action is to call FUNCTION with arguments ARGS. + +This function returns a timer object which you can use in +`cancel-timer'." (interactive "sRun at time: \nNRepeat interval: \naFunction: ") (or (null repeat) @@ -366,13 +381,13 @@ This function returns a timer object which you can use in `cancel-timer'." ;; Handle numbers as relative times in seconds. (if (numberp time) - (setq time (timer-relative-time (current-time) time))) + (setq time (timer-relative-time nil time))) ;; Handle relative times like "2 hours 35 minutes" (if (stringp time) (let ((secs (timer-duration time))) (if secs - (setq time (timer-relative-time (current-time) secs))))) + (setq time (timer-relative-time nil secs))))) ;; Handle "11:23pm" and the like. Interpret it as meaning today ;; which admittedly is rather stupid if we have passed that time @@ -478,7 +493,7 @@ The value is a list that the debugger can pass to `with-timeout-unsuspend' when it exits, to make these timers start counting again." (mapcar (lambda (timer) (cancel-timer timer) - (list timer (time-subtract (timer--time timer) (current-time)))) + (list timer (time-subtract (timer--time timer) nil))) with-timeout-timers)) (defun with-timeout-unsuspend (timer-spec-list) @@ -487,7 +502,7 @@ The argument should be a value previously returned by `with-timeout-suspend'." (dolist (elt timer-spec-list) (let ((timer (car elt)) (delay (cadr elt))) - (timer-set-time timer (time-add (current-time) delay)) + (timer-set-time timer (time-add nil delay)) (timer-activate timer)))) (defun y-or-n-p-with-timeout (prompt seconds default-value) diff --git a/lisp/emacs-lisp/tq.el b/lisp/emacs-lisp/tq.el index d308ce694d2..b652cbe193e 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-2015 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 f605c2865c0..7a2fb22f3d5 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-2015 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'. @@ -222,6 +221,7 @@ 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 @@ -255,12 +255,15 @@ 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 (let ((default (function-called-at-point)) (beg (string-match ":[ \t]*\\'" prompt))) @@ -287,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..35a36b8498c 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-2015 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..b88af1dbe1a 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-2015 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal ;; This file is part of GNU Emacs. @@ -224,92 +224,99 @@ See the `warnings' custom group for user customization features. See also `warning-series', `warning-prefix-function' and `warning-fill-prefix' for additional programming features." - (unless level - (setq level :warning)) - (unless buffer-name - (setq buffer-name "*Warnings*")) - (if (assq level warning-level-aliases) - (setq level (cdr (assq level warning-level-aliases)))) - (or (< (warning-numeric-level level) - (warning-numeric-level warning-minimum-log-level)) - (warning-suppress-p type warning-suppress-log-types) - (let* ((typename (if (consp type) (car type) type)) - (old (get-buffer buffer-name)) - (buffer (or old (get-buffer-create buffer-name))) - (level-info (assq level warning-levels)) - start end) - (with-current-buffer buffer - ;; If we created the buffer, disable undo. - (unless old - (special-mode) - (setq buffer-read-only t) - (setq buffer-undo-list t)) - (goto-char (point-max)) - (when (and warning-series (symbolp warning-series)) - (setq warning-series - (prog1 (point-marker) - (unless (eq warning-series t) - (funcall warning-series))))) - (let ((inhibit-read-only t)) - (unless (bolp) - (newline)) - (setq start (point)) - (if warning-prefix-function - (setq level-info (funcall warning-prefix-function - level level-info))) - (insert (format (nth 1 level-info) - (format warning-type-format typename)) - message) - (newline) - (when (and warning-fill-prefix (not (string-match "\n" message))) - (let ((fill-prefix warning-fill-prefix) - (fill-column 78)) - (fill-region start (point)))) - (setq end (point))) - (when (and (markerp warning-series) - (eq (marker-buffer warning-series) buffer)) - (goto-char warning-series))) - (if (nth 2 level-info) - (funcall (nth 2 level-info))) - (cond (noninteractive - ;; Noninteractively, take the text we inserted - ;; in the warnings buffer and print it. - ;; Do this unconditionally, since there is no way - ;; to view logged messages unless we output them. - (with-current-buffer buffer - (save-excursion - ;; Don't include the final newline in the arg - ;; to `message', because it adds a newline. - (goto-char end) - (if (bolp) - (forward-char -1)) - (message "%s" (buffer-substring start (point)))))) - ((and (daemonp) (null after-init-time)) - ;; Warnings assigned during daemon initialization go into - ;; the messages buffer. - (message "%s" - (with-current-buffer buffer - (save-excursion - (goto-char end) - (if (bolp) - (forward-char -1)) - (buffer-substring start (point)))))) - (t - ;; Interactively, decide whether the warning merits - ;; immediate display. - (or (< (warning-numeric-level level) - (warning-numeric-level warning-minimum-level)) - (warning-suppress-p type warning-suppress-types) - (let ((window (display-buffer buffer))) - (when (and (markerp warning-series) - (eq (marker-buffer warning-series) buffer)) - (set-window-start window warning-series)) - (sit-for 0)))))))) + (if (not (or after-init-time noninteractive (daemonp))) + ;; Ensure warnings that happen early in the startup sequence + ;; are visible when startup completes (bug#20792). + (delay-warning type message level buffer-name) + (unless level + (setq level :warning)) + (unless buffer-name + (setq buffer-name "*Warnings*")) + (if (assq level warning-level-aliases) + (setq level (cdr (assq level warning-level-aliases)))) + (or (< (warning-numeric-level level) + (warning-numeric-level warning-minimum-log-level)) + (warning-suppress-p type warning-suppress-log-types) + (let* ((typename (if (consp type) (car type) type)) + (old (get-buffer buffer-name)) + (buffer (or old (get-buffer-create buffer-name))) + (level-info (assq level warning-levels)) + start end) + (with-current-buffer buffer + ;; If we created the buffer, disable undo. + (unless old + (special-mode) + (setq buffer-read-only t) + (setq buffer-undo-list t)) + (goto-char (point-max)) + (when (and warning-series (symbolp warning-series)) + (setq warning-series + (prog1 (point-marker) + (unless (eq warning-series t) + (funcall warning-series))))) + (let ((inhibit-read-only t)) + (unless (bolp) + (newline)) + (setq start (point)) + (if warning-prefix-function + (setq level-info (funcall warning-prefix-function + level level-info))) + (insert (format (nth 1 level-info) + (format warning-type-format typename)) + message) + (newline) + (when (and warning-fill-prefix (not (string-match "\n" message))) + (let ((fill-prefix warning-fill-prefix) + (fill-column 78)) + (fill-region start (point)))) + (setq end (point))) + (when (and (markerp warning-series) + (eq (marker-buffer warning-series) buffer)) + (goto-char warning-series))) + (if (nth 2 level-info) + (funcall (nth 2 level-info))) + (cond (noninteractive + ;; Noninteractively, take the text we inserted + ;; in the warnings buffer and print it. + ;; Do this unconditionally, since there is no way + ;; to view logged messages unless we output them. + (with-current-buffer buffer + (save-excursion + ;; Don't include the final newline in the arg + ;; to `message', because it adds a newline. + (goto-char end) + (if (bolp) + (forward-char -1)) + (message "%s" (buffer-substring start (point)))))) + ((and (daemonp) (null after-init-time)) + ;; Warnings assigned during daemon initialization go into + ;; the messages buffer. + (message "%s" + (with-current-buffer buffer + (save-excursion + (goto-char end) + (if (bolp) + (forward-char -1)) + (buffer-substring start (point)))))) + (t + ;; Interactively, decide whether the warning merits + ;; immediate display. + (or (< (warning-numeric-level level) + (warning-numeric-level warning-minimum-level)) + (warning-suppress-p type warning-suppress-types) + (let ((window (display-buffer buffer))) + (when (and (markerp warning-series) + (eq (marker-buffer warning-series) buffer)) + (set-window-start window warning-series)) + (sit-for 0))))))))) +;; 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...). -Aside from generating the message with `format', + "Display a warning message made from (format-message MESSAGE ARGS...). +\\<special-mode-map> +Aside from generating the message with `format-message', this is equivalent to `display-warning'. TYPE is the warning type: either a custom group name (a symbol), @@ -325,15 +332,15 @@ LEVEL should be either :debug, :warning, :error, or :emergency :error -- invalid data or circumstances. :warning -- suspicious data or circumstances. :debug -- info for debugging only." - (display-warning type (apply 'format message args) level)) + (display-warning type (apply #'format-message message args) level)) ;;;###autoload (defun warn (message &rest args) - "Display a warning message made from (format MESSAGE ARGS...). -Aside from generating the message with `format', + "Display a warning message made from (format-message MESSAGE ARGS...). +Aside from generating the message with `format-message', this is equivalent to `display-warning', using `emacs' as the type and `:warning' as the level." - (display-warning 'emacs (apply 'format message args))) + (display-warning 'emacs (apply #'format-message message args))) (provide 'warnings) |