diff options
Diffstat (limited to 'lisp/emacs-lisp')
39 files changed, 2200 insertions, 3776 deletions
diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el deleted file mode 100644 index 51bd41530cc..00000000000 --- a/lisp/emacs-lisp/authors.el +++ /dev/null @@ -1,1394 +0,0 @@ -;;; authors.el --- utility for maintaining Emacs's AUTHORS file -*-coding: utf-8 -*- - -;; Copyright (C) 2000-2014 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 P Templeton" "BT Templeton") - ("Brian Sniffen" "Brian T. Sniffen") - ("David Abrahams" "Dave Abrahams") - ("David J. Biesack" "David Biesack") - ("David De La Harpe Golden" "David Golden") - ("David Gillespie" "Dave Gillespie") - ("David Kågedal" "David K..edal") - ("David M. Koppelman" "David 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\\(ward\\( M\\)?\\)? Reingold" "Reingold Edward M") - ("Emilio C. Lopes" "Emilio Lopes") - ("Eric M. Ludlam" "Eric Ludlam") - ("Eric S. Raymond" "Eric Raymond") - ("Fabián Ezequiel Gallina" "Fabian Ezequiel Gallina" "Fabi.n E\\. Gallina") - ("Francis J. Wright" "Dr Francis J. Wright" "Francis Wright") - ("François Pinard" "Francois Pinard") - ("Francesco Potortì" "Francesco Potorti" "Francesco Potorti`") - ("Frederic Pierresteguy" "Fred Pierresteguy") - ("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") - (nil "Code Extracted") ; lisp/newcomment.el's "Author:" header - ("Jaeyoun Chung" "Jae-youn Chung" "Jae-you Chung" "Chung Jae-youn") - ("Jan Djärv" "Jan D." "Jan Djarv") - ("Jay K. Adams" "Jay Adams") - ("Jérôme Marant" "Jérôme Marant" "Jerome Marant") - ("Jens-Ulrik Holger Petersen" "Jens-Ulrik Petersen") - ("Jeremy Bertram Maitin-Shepard" "Jeremy Maitin-Shepard") - ("Johan Bockgård" "Johan Bockgard") - ("John J Foerch" "John Foerch") - ("John W. Eaton" "John Eaton") - ("Jonathan I. Kamens" "Jonathan Kamens") - ("Jorgen Schäfer" "Jorgen Schaefer") - ("Joseph Arceneaux" "Joe Arceneaux") - ("Joseph M. Kelsey" "Joe Kelsey") ; FIXME ? - ("Juan León Lahoz García" "Juan-Leon Lahoz Garcia") - ("Jürgen Hötzel" "Juergen Hoetzel") - ("K. Shane Hartman" "Shane Hartman") - ("Kai Großjohann" "Kai Grossjohann") - ("Karl Berry" "K. Berry") - ("Károly Lőrentey" "Károly Lőrentey" "Lőrentey Károly") - ("Kazushi Marukawa" "Kazushi (Jam) Marukawa") - ("Ken Manheimer" "Kenneth Manheimer") - ("Kenichi Handa" "Ken'ichi Handa" "Kenichi HANDA" "K\\. Handa") - ("Kevin Greiner" "Kevin J. Greiner") - ("Kim F. Storm" "Kim Storm") - ("Kyle Jones" "Kyle E. Jones") - ("Lars Magne Ingebrigtsen" "Lars Ingebrigtsen") - ("Marcus G. Daniels" "Marcus Daniels") - ("Mark D. Baushke" "Mark D Baushke") - ("Mark E. Shoulson" "Mark Shoulson") - ("Marko Kohtala" "Kohtala Marko") - ("Agustín Martín" "Agustin Martin" "Agustín Martín Domingo") - ("Martin Lorentzon" "Martin Lorentzson") - ("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") -;;; ("Tetsurou Okazaki" "OKAZAKI Tetsurou") ; FIXME? - ("Paul Eggert" "Paul R\\. Eggert") - ("Pavel Janík" "Pavel Janík Ml." "Pavel Janik Ml." "Pavel Janik") - ("Pavel Kobiakov" "Pavel Kobyakov") - ("Per Abrahamsen" "Per Abhiddenware") - ("Per Starbäck" "Per Starback") - ("Peter J. Weisberg" "PJ Weisberg") - ("Peter S. Galbraith" "Peter S Galbraith" "Peter Galbraith") - ("Peter Runestig" "Peter 'luna' Runestig") - ("Piotr Zieliński" "Piotr Zielinski") - ("Rainer Schöpf" "Rainer Schoepf") - ("Raja R. Harinath" "Raja R Harinath") - ("Richard G. Bielawski" "Richard G Bielawski" "Richard Bielawski") - ("Richard King" "Dick King") - ("Richard M. Stallman" "Richard Stallman" "rms@gnu.org") - ("Robert J. Chassell" "Bob Chassell") - ("Roberto Huelga Díaz" "Roberto Huelga") - ("Roland B. Roberts" "Roland B Roberts" "Roland Roberts") - ("Rui-Tao Dong" "Rui-Tao Dong ~{6-HpLN~}") - ("Sacha Chua" "Sandra Jean Chua") - ("Sam Steingold" "Sam Shteingold") - ("Satyaki Das" "Indexed search by Satyaki Das") - ("Sébastien Vauban" "Sebastien Vauban") - ("Sergey Litvinov" "Litvinov Sergey") - ;; There are other Stefans. -;;; ("Stefan Monnier" "Stefan") - ("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 - '("Barry O'Reilly" - "Brian van den Broek" - "Bryan O'Sullivan" - "Christian von Roques" - "Christophe de Dinechin" - "Craig McDaniel" - "Daniel LaLiberte" - "David J. MacKenzie" - "David McCabe" - "David O'Toole" - "Devon Sean McCullough" - "Dominique de Waleffe" - "Edward O'Connor" - "Exal de Jesus Garcia Carrillo" - "George McNinch" - "Greg McGary" - "Hans de Graaff" - "Ivan Vilata i Balaguer" - "Jae-hyeon Park" - "James TD Smith" - "Jay McCarthy" - "Joel N. Weber II" - "Matt McClure" - "Mike McLean" - "Michael McNamara" - "Mike McEwan" - "Nelson Jose dos Santos Ferreira" - "Peter von der Ahe" - "Peter O'Gorman" - "Piet van Oostrum" - "Roland McGrath" - "Santiago Payà i Miralta" - "Sean O'Halpin" - "Sean O'Rourke" - "Shun-ichi Goto" - "Thomas DeWeese" - "Tijs van Bakel" - "Yu-ji Hosokawa") - "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 - '(".*loaddefs.el$" ; not obsolete, but auto-generated - "\\.\\(cvs\\|git\\)ignore$" ; obsolete or uninteresting - "\\.arch-inventory$" - "automated/data/" ; not interesting - ;; TODO lib/? Matches other things? - "build-aux/" "m4/" "Emacs.xcodeproj" "mapfiles" "\\.map\\'" - "preferences\\.\\(nib\\|gorm\\)" - ;; Generated files that have since been removed. - "\\(refcard\\(-de\\|-pl\\)?\\|calccard\\|dired-ref\\|orgcard\\|\ -gnus-booklet\\|fr-drdref\\)\\.p\\(df\\|s\\)\\'") - "List of regexps matching obsolete files. -Changes to files matching one of the regexps in this list are not listed.") - -(defconst authors-no-scan-regexps - '("etc/nxml/" - "automated/data/") - "Lists of regexps matching files not to scan for authorship.") - -(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" "install-sh" "missing" "mkinstalldirs" - "termcap.dat" "termcap.src" "termcap.ucb" "termcap" - "ChangeLog.nextstep" "Emacs.clr" "spec.txt" - "gfdl.1" - "texi/Makefile.in" - "Imakefile" "icons/sink.ico" "aixcc.lex" - "nxml/char-name/unicode" - "spec.txt" - "js2-mode.el" ; only installed very briefly, replaced by js.el - ;; In the old imported lisp/url ChangeLog, but never in Emacs. - "mule-sysdp.el" - ;; Only briefly present. - "tests/gnustest-nntp.el" "tests/gnustest-registry.el" - "cedet/tests/testtemplates.cpp" - "cedet/tests/testusing.cpp" - "cedet/tests/scopetest.cpp" - "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" "loaddefs-boot.el" - "compile" "config.guess" "config.sub" "depcomp" - "autogen/compile" "autogen/config.guess" "autogen/config.in" - "autogen/config.sub" "autogen/depcomp" "autogen/install-sh" - "autogen/missing" "autogen" - "autogen/copy_autogen" ; not generated, but trivial and now removed - "dir_top" - ;; Only existed briefly, then renamed: - "images/icons/allout-widgets-dark-bg" - "images/icons/allout-widgets-light-bg" - ;; 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" - "copying.paper" "celibacy.1" "condom.1" "echo.msg" "sex.6" - "COOKIES" "INTERVIEW" "MAILINGLISTS" "MOTIVATION" - "NICKLES.WORTH" "INTERVAL.IDEAS" "RCP" - "3B-MAXMEM" "AIX.DUMP" "SUN-SUPPORT" "XENIX" - "CODINGS" "CHARSETS" - "calc/INSTALL" "calc/Makefile" "calc/README.prev" - "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" - ;; Used to be in admin, not very interesting. - "emacs-pretesters" "make-announcement" "make-changelog-diff" - ;; Textual comments that are not files. - "All" "Version" "Everywhere" "Many" "Various" "files" - ;; Directories. - "vms" "mac" "url" "tree-widget" - ) - "List of files and directories to ignore. -Changes to files in this list are not listed.") - -;; List via: find . -name '*.el' | sed 's/.*\///g' | sort | uniq -d -;; FIXME It would be better to discover these dynamically. -(defconst authors-ambiguous-files - '("Makefile.in" - "makefile.w32-in" - "chart.el" - "cl-lib.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" - "grammar.el" - "greek.el" - "grep.el" - "hebrew.el" - "imenu.el" - "indian.el" - "info-xref.el" - "japanese.el" - "java.el" - "lao.el" - "linux.el" - "locate.el" - "make.el" - "mode.el" - "mule-util.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" - "thingatpt.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") - ;; No longer distributed: freebsd.h - ;; Only trivial pieces remain, merged into configure.ac. - ("Shawn M. Carey" :wrote "[some early FreeBSD support]") - ;; hp800.h renamed from hp9000s800.h, hpux.h merged into hpux10-20.h. - ;; FIXME overwritten by Author:. - ("Satyaki Das" :cowrote "mh-search.el") - ;; No longer distributed: hp800.h, hpux10-20.h. - ;; Only trivial pieces remain, merged into configure.ac. - ("Eric Decker" :changed "sysdep.c (and other files for HP-UX support)") - ("Lawrence R. Dodd" :cowrote "dired-x.el") - ;; No longer distributed. -;;; ("Viktor Dukhovni" :wrote "unexsunos4.c") - ("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") - ;; No longer distributed: ymakefile, intel386.h, mem-limits.h, template.h, - ;; linux.h (was renamed to lignux.h, then to gnu-linux.h, then removed) - ("Michael K. Johnson" :changed "configure.ac" "emacs.c" - "process.c" "sysdep.c" "syssignal.h" "systty.h" "unexcoff.c") - ;; No longer distributed. -;;; ("Kyle Jones" :wrote "mldrag.el") - ("Henry Kautz" :wrote "bib-mode.el") - ;; No longer distributed: vms-pwd.h, vmsfns.c, uaf.h, - ;; dir.h (was renamed to vmsdir.h, then removed) - ("Joseph M. Kelsey" :changed "fileio.c") - ("Sam Kendall" :changed "etags.c" "etags.el") - ;; ack.texi: "We're not using his backquote.el any more." - ("Richard King" :wrote "userlock.el" "filelock.c") - ("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 doc files)") - ("Frederic Pierresteguy" :wrote "widget.c") - ("Michael D. Prange" :changed "tex-mode.el") - ;; No longer distributed (dgux5-4r3.h was renamed to dgux5-4-3.h). -;;; ("Paul Reilly" :wrote "gux5-4r2.h" "dgux5-4-3.h") - ("Rob Riepel" :wrote "tpu-edt.doc") - ("Roland B. Roberts" :changed "files.el" "sort.el" - "buffer.h" "callproc.c" "dired.c" "process.c" "sysdep.c" "systty.h") - ;; No longer distributed. -;;; "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, now a generated file. - ;; ecrt0.c renamed from crt0.c, then removed. - "data.c" "fns.c" - "lisp.h" "lread.c" ; "sun3.h" "ymakefile" - no longer distributed - "print.c" :wrote "float-sup.el" "floatfns.c") - ("Schlumberger Technology Corporation" :changed "gud.el") - ;; Replaced by tcl.el. -;;; ("Gregor Schmid" :wrote "tcl-mode.el") - ;; No longer distributed since 24.1. -;;; ("Rainer Schöpf" :wrote "alpha.h" "unexalpha.c") - ;; No longer distributed: emacsserver.c. - ("William Sommerfeld" :wrote "emacsclient.c" "scribe.el") - ;; No longer distributed: emacsserver.c. - ("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") - ;; No longer distributed: usg5-4.h - ("James Van Artsdalen" :changed "unexcoff.c") - ;; No longer distributed: src/makefile.nt, lisp/makefile.nt - ;; winnt.el renamed to w32-fns.el; nt.[ch] to w32.[ch]; - ;; ntheap.[ch] to w32heap.[ch]; ntinevt.c to w32inevt.c; - ;; 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]" - "[tty menus in term.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" - "Makefile.noleim" - "makedist.bat" - "makefile.def" - "makefile.nt" - "ns.mk" - "README" - ;; There were a few of these, not just the generated top-level one. - "configure" "config.h" - ;; nt/ - "ebuild.bat" "install.bat" "fast-install.bat" - "debug.bat.in" "emacs.bat.in" - "inc/sys/dir.h" "inc/gettext.h" - ".gdbinit-union" - "alloca.s" - "make-delta" - "config.w95" - "msysconfig.sh" - "emacstool.1" - "align.umax" - "cxux-crt0.s" - "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" - "ps-prin2.ps" "ps-prin3.ps" - "emacs.xbm" "gnu.xpm" "gnus-pointer.xbm" "gnus-pointer.xpm" - ;; Moved from etc/ to etc/images, and/or removed. - "gnus.pbm" "gnus.xbm" "gnus.xpm" "letter.pbm" "letter.xbm" "letter.xpm" - "splash.pbm" "splash.xbm" "splash.xpm" "splash8.xpm" - "images/execute.pbm" "images/execute.xpm" "images/fld-open.pbm" - "images/fld-open.xpm" "images/highlight.pbm" "images/highlight.xpm" - "images/mail.pbm" "images/mail.xpm" "images/mail/alias.pbm" - "images/mail/alias.xpm" "images/mail/refile.pbm" - "images/mail/refile.xpm" "images/page-down.pbm" - "images/page-down.xpm" "images/widen.pbm" "images/widen.xpm" - "images/gnus/bar.xbm" "images/gnus/bar.xpm" - "images/gnus/reverse-smile.xpm" - "revdiff" ; admin/ - "vcdiff" "rcs-checkin" "tindex.pl" - "mainmake" "sed1.inp" "sed2.inp" "sed3.inp" ; msdos/ - "mac-fix-env.m" - ;; Deleted vms stuff: - "temacs.opt" "descrip.mms" "compile.com" "link.com" - "compact.el" "fadr.el" - "calc/calc-maint.el" - "emacs-lisp/cl-specs.el" - "emacs-lisp/eieio-comp.el" - "erc-hecomplete.el" - "eshell/esh-maint.el" - "language/persian.el" - "ledit.el" "meese.el" "iswitchb.el" "longlines.el" - "mh-exec.el" "mh-init.el" "mh-customize.el" - "net/zone-mode.el" "xesam.el" - "term/mac-win.el" "sup-mouse.el" - "url-https.el" - "org-mac-message.el" "org-mew.el" "org-w3m.el" "org-vm.el" "org-wl.el" - "org-mks.el" "org-remember.el" "org-xoxo.el" "org-docbook.el" - "org-freemind.el" "ox-jsinfo.el" - "org-exp-blocks.el" ; maybe this is ob-exp now? dunno - "org-lparse.el" - "org-special-blocks.el" "org-taskjuggler.el" - ;; gnus - "nnwfm.el" "nnlistserv.el" "nnkiboze.el" "nndb.el" "nnsoup.el" - "netrc.el" "password.el" "sasl-cram.el" "sasl-digest.el" "sasl-ntlm.el" - "sasl.el" "dig.el" "dns.el" "hex-util.el" "sha1.el" "md4.el" - "hmac-def.el" "hmac-md5.el" "ntlm.el" "hashcash.el" "smime-ldap.el" - "assistant.el" "gnus-utils.el" "tls.el" "pgg-def.el" "pgg-gpg.el" - "gnus-compat.el" "pgg-parse.el" "pgg-pgp.el" "pgg-pgp5.el" "pgg.el" - "dns-mode.el" "run-at-time.el" "gnus-encrypt.el" "sha1-el.el" - "gnus-gl.el" "gnus.sum.el" "proto-stream.el" "color.el" "color-lab.el" - "eww.el" "shr-color.el" "shr.el" "earcon.el" "gnus-audio.el" "encrypt.el" - "format-spec.el" "gnus-move.el" - ;; doc - "getopt.c" "texindex.c" "news.texi" "vc.texi" "vc2-xtra.texi" - "back.texi" "vol1.texi" "vol2.texi" "elisp-covers.texi" "two.el" - "front-cover-1.texi" "locals.texi" "calendar.texi" "info-stnd.texi" - "tasks.texi" - "advice.texi" "picture.texi" "texinfo.tex" - ;; lwlib: - "dispatch.c" "dispatch.h" "xrdb-cpp.c" "xrdb.c" - "lwlib-Xol.c" "lwlib-Xol.h" "lwlib-Xolmb.c" "lwlib-Xolmb.h" - "lwlib-XolmbP.h" - ;; lib/ - "lib/stdio.c" "lib/gl_openssl.h" "lib/sigprocmask.c" - "lib/pthread_sigprocmask.c" "lib/ldtoastr.c" "lib/dummy.c" - "lib/ignore-value.h" - ;; lib-src/ - "cvtmail.c" "digest-doc.c" "emacsserver.c" "emacstool.c" "env.c" - "etags-vmslib.c" "fakemail.c" "getdate.c" "getopt.h" "getopt1.c" - "getopt_.h" "getopt_int.h" "gettext.h" "leditcfns.c" "loadst.c" - "make-path.c" "qsort.c" "sorted-doc.c" "tcp.c" "timer.c" "wakeup.c" - "yow.c" - ;; etc/ - "emacsclient.c" "etags.c" "hexl.c" "make-docfile.c" "movemail.c" - "test-distrib.c" "testfile" - "tpu-edt.doc" ; see below - ) - "File names which are valid, but no longer exist (or cannot be found) -in the repository.") - -;; Note that any directory part on the RHS is retained. -;; Cf authors-renamed-files-regexps. -;; NB So only add a directory if needed to disambiguate. -;; FIXME? -;; Although perhaps we could let authors-disambiguate-file-name do that? -(defconst authors-renamed-files-alist - '(("nt.c" . "w32.c") ("nt.h" . "w32.h") - ("ntheap.c" . "w32heap.c") ("ntheap.h" . "w32heap.h") - ("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") - ("src/config.h" . "config.h") - ("winnt.el" . "w32-fns.el") - ("linux.h" . "gnu-linux.h") - ("emacs.manifest" . "emacs-x86.manifest") - ("config.emacs" . "configure") - ("configure.in" . "configure.ac") - ("config.h.dist" . "config.in") - ("config.h-dist" . "config.in") - ("config.h.in" . "config.in") - ("debug.bat" . "debug.bat.in") - ("emacs.bat" . "emacs.bat.in") - ;; paths.h.dist -> paths.h-dist -> paths.h.in -> paths.in -> epaths.in. - ("paths.h.dist" . "epaths.in") - ("paths.h-dist" . "epaths.in") - ("paths.h.in" . "epaths.in") - ("paths.in" . "epaths.in") - ("patch1" . "sed1.inp") - ("INSTALL.MSYS" . "INSTALL") - ("server.c" . "emacsserver.c") - ("lib-src/etags.c" . "etags.c") - ;; msdos/ - ("is-exec.c" . "is_exec.c") - ("enriched.doc" . "enriched.txt") - ("GETTING.GNU.SOFTWARE" . "FTP") - ("etc/MACHINES" . "MACHINES") - ("ONEWS" . "NEWS.19") - ("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") - ;; Moved from lisp/tpu-doc.el to etc/tpu-edt.doc in Emacs 19.29. - ;; Removed in Emacs 19.30, replaced by new file etc/edt-user.doc - ;; (no associated ChangeLog entry). - ("tpu-doc.el" . "tpu-edt.doc") - ("Makefile.in.in" . "Makefile.in") - ("leim-Makefile" . "leim/Makefile") - ("leim-Makefile.in" . "leim/Makefile.in") - ("emacs-lisp/testcover-ses.el" . "tcover-ses.el") - ("emacs-lisp/testcover-unsafep.el" . "tcover-unsafep.el") - ("progmodes/dos.el" . "bat-mode.el") - ;; index and pick merged into search. - ("mh-index.el" . "mh-search.el") - ("mh-pick.el" . "mh-search.el") - ("font-setting.el" . "dynamic-setting.el") - ("help-funs.el" . "help-fns.el") - ("erc-notifications.el" . "erc-desktop-notifications.el") - ("org-complete.el" . "org-pcomplete.el") - ("org-export.el" . "ox.el") ; ? - ;; Was definitely renamed to org-latex.el, then... ? - ("org-export-latex.el" . "ox-latex.el") ; ? - ("org-exp.el" . "ox.el") ; ? - ("progmodes/cfengine3.el" . "cfengine.el") - ("progmodes/delphi.el" . "opascal.el") - ("octave-inf.el" . "octave.el") - ("octave-mod.el" . "octave.el") - ("progmodes/octave-inf.el" . "octave.el") - ("progmodes/octave-mod.el" . "octave.el") - ;; Obsolete. - ("emacs-lisp/assoc.el" . "assoc.el") - ("emacs-lisp/cust-print.el" . "cust-print.el") - ("mail/mailpost.el" . "mailpost.el") - ("play/bruce.el" . "bruce.el") - ("play/yow.el" . "yow.el") - ("patcomp.el" . "patcomp.el") - ;; From lisp to etc/forms. - ("forms-d2.el" . "forms-d2.el") - ("forms-pass.el" . "forms-pass.el") - ;; From lisp/ to etc/nxml. - ("nxml/test.invalid.xml" . "test-invalid.xml") - ("nxml/test.valid.xml" . "test-valid.xml") - ;; The one in lisp is eshell/eshell.el. - ("eshell.el" . "automated/eshell.el") - ("eshell/esh-test.el" . "automated/eshell.el") - ;; INSTALL-CVS -> .CVS -> .BZR -> .REPO - ("INSTALL-CVS" . "INSTALL.REPO") - ("INSTALL.CVS" . "INSTALL.REPO") - ("INSTALL.BZR" . "INSTALL.REPO") - ("gnus-logo.eps" . "gnus-logo.eps") ; moved to refcards/ - ("build-install" . "build-ins.in") - ("build-install.in" . "build-ins.in") - ("unidata/Makefile" . "unidata/Makefile.in") - ("mac/uvs.el" . "unidata/uvs.el") - ;; Moved from top to etc/ - ("CONTRIBUTE" . "CONTRIBUTE") - ("FTP" . "FTP") - ;; Moved from top to build-aux/ - ("move-if-change" . "move-if-change") - ("update-subdirs" . "update-subdirs") - ("emacs.tex" . "emacs.texi") - ("faq.texi" . "efaq.texi") - ("major.texi" . "modes.texi") - ;; And from emacs/ to misc/ and back again. - ("ns-emacs.texi" . "macos.texi") - ("overrides.texi" . "gnus-overrides.texi") - ("xresmini.texi" . "xresources.texi") - ;; Not renamed, but we only have the latter in the Emacs repo. - ("trampver.texi.in" . "trampver.texi") - ;; Renamed with same directory. - ("e/eterm" . "eterm-color") - ("e/eterm.ti" . "eterm-color.ti") - ("README.txt" . "README") - ("emacs.names" . "JOKES") - ("ED.WORSHIP" . "JOKES") - ("GNU.JOKES" . "JOKES") - ("CHARACTERS" . "TODO") - ("images/gnus/mail_send.xpm" . "mail-send.xpm") ; still in images/gnus - ;; Renamed within same directory. - ("schema/xhtml-basic-form.rnc" . "xhtml-bform.rnc" ) - ("schema/xhtml-basic-table.rnc" . "xhtml-btable.rnc") - ("schema/xhtml-list.rnc" . "xhtml-lst.rnc") - ("schema/xhtml-target.rnc" . "xhtml-tgt.rnc") - ("schema/xhtml-style.rnc" . "xhtml-xstyle.rnc") - ("schema/docbook-dyntbl.rnc" . "docbk-dyntbl.rnc") - ("schema/docbook-soextbl.rnc" . "docbk-soextbl.rn" ) - ("edt-user.doc" . "edt.texi") - ("DEV-NOTES" . "nextstep") - ("org/COPYRIGHT-AND-LICENSE" . "org/README") - ;; 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") - ("ja-dic" . "leim/ja-dic") - ("quail" . "leim/quail") - ;; Moved from autogen/ to admin/. - ("autogen/update_autogen" . "update_autogen") - ;; Moved from etc/ to admin/. - ("grammars" . "grammars") - ;; From etc to lisp/cedet/semantic/. - ("grammars/bovine-grammar.el" . "bovine/grammar.el") - ("grammars/wisent-grammar.el" . "wisent/grammar.el") - ;; Moved from admin/nt/ to nt/. - ("nt/README.W32" . "README.W32") - ) - "Alist of files which have been renamed during their lifetime. -Elements are (OLDNAME . NEWNAME).") - -;; Should still test that the renamed file exists. Does it? -;; But it might be relative to a different ChangeLog... -;; -;; Note that only the basename of the RHS is used. -;; Cf authors-renamed-files-alist. -(defconst authors-renamed-files-regexps - '(("\\`\\(arg-nonnull\\|c\\+\\+defs\\|warn-on-use\\)\\.h\\'" - "build-aux/snippet/\\&") - ("\\`\\(ebuild\\|emacs\\|install\\|fast-install\\)\\.cmd\\'" "\\1.bat") - ("\\`\\(book-spine\\|cl\\|forms\\|functions\\|gnus\\|sc\\|texinfo\\|vip\\)\ -\\.texinfo\\'" "\\1.texi") - ("\\`\\(\\(calc\\|org\\|vip\\)card\\|viperCard\\|\ -\\(\\(cs\\|fr\\|sk\\)-\\)?dired-ref\\|\ -\\(\\(cs\\|de\\|fr\\|gnus\\|pl\\|pt-br\\|ru\\|sk\\)-\\)?refcard\\|\ -\\(\\(cs\\|fr\\|sk\\)-\\)?survival\\)\\.tex\\'" "refcards/\\&") - ("\\`refcard-\\(de\\|pl\\)\\.tex\\'" "refcards/\\1-refcard.tex") - ("\\`\\(refcards/\\)?fr-drdref\\.tex\\'" "refcards/fr-dired-ref.tex") - ("^\\(TUTORIAL[^/]*\\)" "tutorials/\\1") - ("\\`themes/dev-\\(tsdh-\\(?:light\\|dark\\)-theme\\.el\\)\\'" - "themes/\\1") - ;; Moved from lisp/toolbar to etc/images. - ("\\`toolbar/\\(back\\|fwd\\|left\\|right\\|up\\)_arrow\ -\\(\\.\\(?:pb\\|xp\\)m\\)\\'" "images/\\1-arrow\\2") - ("\\`toolbar/lc-\\(back\\|fwd\\|left\\|right\\|up\\)_arrow\ -\\(\\.\\(?:pb\\|xp\\)m\\)\\'" "images/low-color/\\1-arrow\\2") - ("\\`toolbar/mail_\\(compose\\|send\\)\\(\\.[xp]bm\\)\\'" - "images/mail/\\1") - ("\\`toolbar/jump_to\\(\\.\\(?:pb\\|xp\\)m\\)\\'" "images/jump-to\\1") - ("\\`toolbar/lc-jump_to\\(\\.\\(?:pb\\|xp\\)m\\)\\'" - "images/low-color/jump-to\\1") - ("\\`toolbar/\\(attach\\|cancel\\|close\\|copy\\|cut\\|\ -diropen\\|exit\\|help\\|home\\|index\\|info\\|mail\\|new\\|open\\|\ -paste\\|preferences\\|print\\|save\\|saveas\\|search\\|search-replace\\|\ -spell\\|undo\\)\\(\\.\\(?:pb\\|xp\\)m\\)\\'" "images/\\1\\2") - ("\\`toolbar/gud-\\(break\\|cont\\|down\\|finish\\|print\\|pstar\\|\ -remove\\|run\\|until\\|up\\|watch\\)\\(\\.\\(?:pb\\|xp\\)m\\)\\'" - "images/gud/\\1\\2") - ("\\`\\(toolbar/gud-\\|images/gud/\\)n\\(i\\)?\\(\\.\\(?:pb\\|xp\\)m\\)\\'" - "images/gud/next\\2\\3") - ("\\`\\(toolbar/gud-\\|images/gud/\\)s\\(i\\)?\\(\\.\\(?:pb\\|xp\\)m\\)\\'" - "images/gud/step\\2\\3") - ("\\`toolbar/lc-\\([-a-z]+\\.xpm\\)\\'" "images/low-color/\\1") - ("^\\(tree-widget/\\(?:default\\|folder\\)/[-a-z]+\\.\\(png\\|xpm\\)\\)$" - "images/\\1") - ("^\\(images/icons/\\)mac\\(emacs\\)_\\([0-9]+\\)\\(\\.png\\)" - "\\1\\2\\3_mac\\4") - ("\\(images/icons/\\)emacs_\\([0-9][0-9]\\)\\.png" - "\\1hicolor/\\2x\\2/apps/emacs.png") - ;; Moved from leim/ to lisp/leim/. - ("\\`quail/[-a-z0-9]+\\.el\\'" "leim/\\&") - ("\\`ja-dic/ja-dic\\.el\\'" "leim/\\&") - ("\\`vc-\\(rcs\\|cvs\\|sccs\\)-hooks\\.el\\'" "vc/vc-\\1.el") - ("\\`vc-\\(annotate\\|arch\\|bzr\\|cvs\\|dav\\|dir\\|dispatcher\\|\ -git\\|hg\\|hooks\\|mtn\\|rcs\\|sccs\\|svn\\)\\.el\\'" "vc/\\&") - ("\\`ediff-\\(diff\\|help\\|hook\\|init\\|merg\\|mult\\|ptch\\|util\\|\ -vers\\|wind\\)\\.el\\'" "vc/\\&") - ("\\`pcvs-\\(defs\\|info\\|parse\\|util\\)\\.el\\'" "vc/\\&") - ("\\`\\(add-log\\|compare-w\\|cvs-status\\|diff-mode\\|diff\\|\ -ediff\\|emerge\\|log-edit\\|log-view\\|pcvs\\|smerge-mode\\|vc\\)\\.el\\'" - "vc/\\&") - ("\\`\\(emacs-lisp/\\)?helpers\\.el\\'" "emacs-lisp/subr-x.el") - ;; I assume this is (essentially) what happened, org/ChangeLog is vague. - ("\\`org-\\(ascii\\|beamer\\|html\\|icalendar\\|jsinfo\\|latex\ -\\|odt\\|publish\\)\\.el\\'" "ox-\\1.el") - ;; From test/ to test/automated/. - ("comint-testsuite.el" "automated/\\&") - ("\\`\\(bytecomp\\|font-parse\\|icalendar\\|occur\\|newsticker\\)\ --testsuite\\.el" "automated/\\1-tests.el") - ;; NB lax rules should come last. - ("^m/m-\\(.*\\.h\\)$" "m/\\1" t) - ("^m-\\(.*\\.h\\)$" "\\1" t) - ("^s/s-\\(.*\\.h\\)$" "s/\\1" t) - ("^s-\\(.*\\.h\\)$" "\\1" t) - ("\\.\\(el\\|[ch]\\|x[pb]m\\|pbm\\)\\'" t t) - ) - "List of regexps and rewriting rules for renamed files. -Elements are (REGEXP REPLACE [LAX]). If REPLACE is a string, the file -name matching REGEXP is replaced by REPLACE using `replace-string'. -Otherwise, the file name is accepted as is. -Elements with LAX non-nil are only used in `authors-lax-changelogs'.") - -;; It's really not worth trying to make these old logs fully valid. -;; All the obvious real errors are gone. -;; The main issue is _lots_ of moving around of files. -;; Eg the progmodes/ (etc) directories did not exist before 1997. -;; Also, lib-src/ did not exist, the files were in etc/. -;; And various other things. -;; Maybe this should just be any ChangeLog with a . extension, -;; assuming we always fix logs fully before rotating them? -(defconst authors-lax-changelogs - '("erc/ChangeLog\\.0[1-8]\\'" - "gnus/ChangeLog\\.[1-2]\\'" - "lisp/ChangeLog\\.\\([1-9]\\|1[0-5]\\)\\'" - "mh-e/ChangeLog\\.1\\'" - "src/ChangeLog\\.\\([1-9]\\|1[0-2]\\)\\'") - "List of regexps matching ChangeLogs that we do not print errors from. -These are older ChangeLogs that have various issues. -Additionally, for these logs we apply the `lax' elements of -`authors-renamed-files-regexps'.") - - -(defvar authors-checked-files-alist) -(defvar authors-invalid-file-names) - -;; This has become rather yucky. :( -(defun authors-disambiguate-file-name (fullname) - "Convert FULLNAME to an unambiguous relative-name." - (let ((relname (file-name-nondirectory fullname)) - dir parent) - (if (and (member relname authors-ambiguous-files) - ;; Try to identify the top-level directory. - ;; FIXME should really use ROOT from M-x authors. - (not (and (file-directory-p - (expand-file-name - "lib-src" - (setq dir (file-name-directory fullname)))) - (file-directory-p (expand-file-name "etc" dir))))) - ;; I think it looks weird to see eg "lisp/simple.el". - ;; But for eg Makefile.in, we do want to say "lisp/Makefile.in". - (if (and (string-equal "lisp" - (setq parent (file-name-nondirectory - (directory-file-name dir)))) - ;; TODO better to simply have hard-coded list? - ;; Only really Makefile.in where this applies. - (not (file-exists-p - (expand-file-name (concat "../" relname) dir)))) - relname - ;; In case of ambiguity, just prepend the parent directory. - ;; FIXME obviously this is not a perfect solution. - (format "%s/%s" (file-name-nondirectory (directory-file-name dir)) - relname)) - relname))) - -(defun authors-lax-changelog-p (file) - "Return non-nil if FILE matches `authors-lax-changelogs'." - (let ((list authors-lax-changelogs) - found) - (while list - (setq list (if (setq found (string-match-p (car list) file)) - nil - (cdr list)))) - found)) - -(defun authors-canonical-file-name (file log-file pos author) - "Return canonical file name for FILE found in LOG-FILE. -Checks whether FILE is a valid (existing) file name, has been renamed, -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)) - laxlog relname valid) - (if entry - (cdr entry) - (setq relname (file-name-nondirectory file)) - (if (or (member file authors-valid-file-names) - (member relname authors-valid-file-names) - (file-exists-p file) - (file-exists-p relname) ; FIXME? appropriate? - ) - (setq valid (authors-disambiguate-file-name fullname)) - (if (setq valid (assoc file authors-renamed-files-alist)) - (setq valid (cdr valid)) - (setq laxlog (authors-lax-changelog-p log-file)) - (let ((rules authors-renamed-files-regexps) - rule) - (while rules - (setq rule (car rules)) - (if (and (or laxlog (not (nth 2 rule))) - (string-match (car rule) file)) - (setq valid (if (stringp (nth 1 rule)) - (file-name-nondirectory - (replace-match (nth 1 rule) 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) - laxlog) - (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-no-scan-file-p (file) - "Return non-nil if FILE should not be scanned. -FILE is not scanned if it matches any of `authors-no-scan-regexps'." - (let (no-scan-p - (regexps authors-no-scan-regexps)) - (while (and regexps (not no-scan-p)) - (setq no-scan-p (string-match-p (car regexps) file) - regexps (cdr regexps))) - no-scan-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) - (unless (authors-no-scan-file-p file) - (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) - (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))) - (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 361e8fa7c68..01f59704a39 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -120,7 +120,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 +141,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. @@ -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) diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 813576efb46..43484801b5a 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -1,4 +1,4 @@ -;;; avl-tree.el --- balanced binary trees, AVL-trees +;;; avl-tree.el --- balanced binary trees, AVL-trees -*- lexical-binding:t -*- ;; Copyright (C) 1995, 2007-2014 Free Software Foundation, Inc. @@ -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)) diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index a497acd637e..5cecbcd4335 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -148,16 +148,19 @@ 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) - (if (> (length s) 2) - ;; We could support it with: (cons 2 `(list . ,(cdr s))) - ;; But let's not encourage such uses. - (error "Multiple args to , are not supported: %S" s) - (cons 1 (nth 1 s))) + (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) @@ -215,9 +218,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/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index fe6640cc51e..ee0a5a11c7b 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -944,15 +944,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 diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 4b9e6d8fd23..8bf63ea572e 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -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,27 +94,55 @@ 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 @@ -115,10 +156,10 @@ 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.") +and should return the code to use to set this property. + +This is used by `declare'.") -(put 'defmacro 'doc-string-elt 3) -(put 'defmacro 'lisp-indent-function 2) (defalias 'defmacro (cons 'macro @@ -218,7 +259,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. @@ -389,13 +431,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'." +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 51006d7c471..13b9f937249 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -417,7 +417,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) @@ -425,31 +425,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 (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 + (cons '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 + (cons '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.") @@ -1349,6 +1369,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 @@ -1357,52 +1404,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)) + (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))))))) (defvar byte-compile-cl-functions nil "List of functions defined in CL.") @@ -2103,11 +2124,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) @@ -2120,6 +2136,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)) @@ -2205,9 +2230,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) @@ -2510,7 +2538,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) @@ -2712,7 +2741,9 @@ for symbols generated by the byte compiler itself." ;; byte-string, constants-vector, stack depth (cdr compiled) ;; optionally, the doc string. - (cond (lexical-binding + (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))) @@ -2950,7 +2981,8 @@ for symbols generated by the byte compiler itself." (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) @@ -3788,6 +3820,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 @@ -4057,9 +4093,8 @@ 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 t +(defvar byte-compile--use-old-handlers nil "If nil, use new byte codes introduced in Emacs-24.4.") (defun byte-compile-catch (form) @@ -4092,12 +4127,6 @@ binding slots have been popped." (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) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 40f1531e0f7..3e17e38fe39 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -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 @@ -140,7 +140,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))))) @@ -152,7 +152,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)) @@ -462,10 +462,6 @@ places where they originally did not directly appear." `(,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 @@ -529,7 +525,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. @@ -561,7 +557,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 @@ -586,10 +582,10 @@ FORM is the parent form that binds this var." (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 @@ -605,7 +601,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. @@ -632,7 +628,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) @@ -641,13 +637,13 @@ 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)) + (cconv--analyze-function vrs body-forms env form)) (`(setq . ,forms) ;; If a local variable (member of env) is modified by setq then @@ -655,7 +651,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. @@ -663,11 +659,11 @@ 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)))) (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote @@ -676,13 +672,13 @@ and updates the data stored in ENV." (guard byte-compile--use-old-handlers)) ;; FIXME: The bytecode for condition-case forces us to wrap the ;; form and handlers in closures. - (cconv--analyse-function () (list protected-form) env form) + (cconv--analyze-function () (list protected-form) env form) (dolist (handler handlers) - (cconv--analyse-function (if var (list var)) (cdr handler) + (cconv--analyze-function (if var (list var)) (cdr handler) env form))) (`(condition-case ,var ,protected-form . ,handlers) - (cconv-analyse-form protected-form env) + (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))) @@ -690,26 +686,21 @@ and updates the data stored in ENV." (if var (push varstruct env)) (dolist (handler handlers) (dolist (form (cdr handler)) - (cconv-analyse-form form env))) - (if var (cconv--analyse-use (cons (list var) (cdr varstruct)) + (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-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)) + (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 @@ -719,8 +710,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 @@ -728,19 +719,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/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index e1919c3bb8d..a94dcd335b4 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -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 @@ -406,6 +383,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. @@ -575,7 +588,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 +606,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 +646,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) diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 6c62ce5c830..2d8a1c4c1c2 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -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) @@ -154,6 +156,15 @@ 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." @@ -245,9 +256,17 @@ 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]")) + (looking-at (if (derived-mode-p 'emacs-lisp-mode) + "(\\(cl-\\)?[Ll][Oo][Oo][Pp]" + "([Ll][Oo][Oo][Pp]"))) (common-lisp-loop-part-indentation indent-point state) (common-lisp-indent-function-1 indent-point state))) @@ -291,18 +310,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) @@ -764,7 +794,11 @@ 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) ;(defun foo (x) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 219d76f85d1..cc61597d313 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -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) @@ -282,6 +279,25 @@ 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))) + (defvar cl--random-state (vector 'cl--random-state-tag -1 30 (cl--random-time))) @@ -361,7 +377,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.") @@ -625,7 +647,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 +701,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,12 +723,11 @@ 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. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index e45efa328ee..0a6e1c63cf1 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -135,7 +135,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." @@ -816,7 +822,8 @@ 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 @@ -1130,7 +1137,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))) @@ -1188,7 +1196,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) @@ -1364,7 +1373,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))) @@ -1382,7 +1392,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)) @@ -1397,7 +1408,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)) @@ -1428,7 +1441,8 @@ For more details, see Info node `(cl)Loop Facility'. (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) (push `(progn ,(if (eq temp what) set `(let ((,temp ,what)) ,set)) - t) cl--loop-body))) + t) + cl--loop-body))) ((eq word 'with) (let ((bindings nil)) @@ -1499,7 +1513,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"). @@ -1540,7 +1555,7 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings." (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) + (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. @@ -1878,13 +1893,13 @@ 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 `(lambda ,@(cdr res))) + macroexpand-all-environment)))))) (defconst cl--old-macroexpand (if (and (boundp 'cl--old-macroexpand) @@ -2057,10 +2072,21 @@ 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 + (let* ((temp (if (cl--simple-expr-p form 3) + form (make-symbol "--cl-var--"))) + (body `(progn (unless ,(cl--make-type-test temp type) + (signal 'wrong-type-argument + (list ',type ,temp ',form))) + ,temp))) + (if (eq temp form) body + `(let ((,temp ,form)) ,body))))) (defvar cl--proclaim-history t) ; for future compilers (defvar cl--declare-stack t) ; for future compilers @@ -2381,7 +2407,8 @@ non-nil value, that slot cannot be set via `setf'. pred-form pred-check) (if (stringp (car descs)) (push `(put ',name 'structure-documentation - ,(pop descs)) forms)) + ,(pop descs)) + forms)) (setq descs (cons '(cl-tag-slot) (mapcar (function (lambda (x) (if (consp x) x (list x)))) descs))) @@ -2460,6 +2487,8 @@ non-nil value, that slot cannot be set via `setf'. (setq type 'vector 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) @@ -2475,7 +2504,8 @@ non-nil value, that slot cannot be set via `setf'. 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)) @@ -2497,7 +2527,8 @@ non-nil value, that slot cannot be set via `setf'. ',accessor ',name)))) ,(if (eq type 'vector) `(aref cl-x ,pos) (if (= pos 0) '(car cl-x) - `(nth ,pos cl-x)))) forms) + `(nth ,pos cl-x)))) + forms) (push (cons accessor t) side-eff) (if (cadr (memq :read-only (cddr desc))) (push `(gv-define-expander ,accessor @@ -2529,12 +2560,14 @@ 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) + ,(if (eq (car pred-form) 'and) + (append pred-form '(t)) + `(and ,pred-form t))) + forms) + (push `(put ',name 'cl-deftype-satisfies ',predicate) forms) + (push (cons predicate 'error-free) side-eff)) (and copier (progn (push `(defun ,copier (x) (copy-sequence x)) forms) (push (cons copier t) side-eff))) @@ -2550,7 +2583,8 @@ non-nil value, that slot cannot be set via `setf'. slots defaults))) (push `(cl-defsubst ,name (&cl-defs '(nil ,@descs) ,@args) - (,type ,@make)) forms) + (,type ,@make)) + forms) (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) (push (cons name t) side-eff)))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) @@ -2572,21 +2606,38 @@ non-nil value, that slot cannot be set via `setf'. (put ',name 'cl-struct-include ',include) (put ',name 'cl-struct-print ,print-auto) ,@(mapcar (lambda (x) - `(put ',(car x) 'side-effect-free ',(cdr x))) + `(function-put ',(car x) 'side-effect-free ',(cdr x))) side-eff)) forms) `(progn ,@(nreverse (cons `',name forms))))) -;;; 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))))) +(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)) + (car (get struct-type 'cl-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)) + (get struct-type 'cl-struct-slots)) + +(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 (cl-position slot-name + (cl-struct-slot-info struct-type) + :key #'car :test #'eq) + (error "struct %s has no slot %s" struct-type slot-name))) (defvar byte-compile-function-environment) (defvar byte-compile-macro-environment) @@ -2600,46 +2651,48 @@ Of course, we really can't know that for sure, so it's just a heuristic." (cdr (assq sym byte-compile-macro-environment)))))) (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")))) - (cond - ((cl--macroexp-fboundp namep) (list namep val)) - ((cl--macroexp-fboundp - (setq namep (intern (concat name "-p")))) - (list namep val)) - (t (list type val)))))) - (cond ((get (car type) 'cl-deftype-handler) - (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler) - (cdr type)))) - ((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))))) + (pcase type + ((and `(,name . ,args) (guard (get name 'cl-deftype-handler))) + (cl--make-type-test val (apply (get name 'cl-deftype-handler) + args))) + (`(,(and name (or 'integer 'float 'real 'number)) + . ,(or `(,min ,max) pcase--dontcare)) + `(and ,(cl--make-type-test val name) + ,(if (memq min '(* nil)) t + (if (consp min) `(> ,val ,(car min)) + `(>= ,val ,min))) + ,(if (memq max '(* nil)) t + (if (consp max) + `(< ,val ,(car max)) + `(<= ,val ,max))))) + (`(,(and name (or 'and 'or 'not)) . ,args) + (cons name (mapcar (lambda (x) (cl--make-type-test val x)) args))) + (`(member . ,args) + `(and (cl-member ,val ',args) t)) + (`(satisfies ,pred) `(funcall #',pred ,val)) + ((and (pred symbolp) (guard (get type 'cl-deftype-handler))) + (cl--make-type-test val (funcall (get type 'cl-deftype-handler)))) + ((and (pred symbolp) (guard (get type 'cl-deftype-satisfies))) + `(funcall #',(get type 'cl-deftype-satisfies) ,val)) + ((or 'nil 't) type) + ('null `(null ,val)) + ('atom `(atom ,val)) + ('float `(floatp ,val)) + ('real `(numberp ,val)) + ('fixnum `(integerp ,val)) + ;; FIXME: Implement `base-char' and `extended-char'. + ('character `(characterp ,val)) + ((pred symbolp) + (let* ((name (symbol-name type)) + (namep (intern (concat name "p")))) + (cond + ((cl--macroexp-fboundp namep) (list namep val)) + ((cl--macroexp-fboundp + (setq namep (intern (concat name "-p")))) + (list namep val)) + ((cl--macroexp-fboundp type) (list type val)) + (t (error "Unknown type %S" type))))) + (_ (error "Bad type spec: %s" type)))) (defvar cl--object) ;;;###autoload @@ -2714,7 +2767,12 @@ and then returning foo." (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) @@ -2848,9 +2906,8 @@ The function's arguments should be treated as immutable. ;;;###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 @@ -2873,19 +2930,47 @@ The function's arguments should be treated as immutable. ;;; 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))))) + +;;; Additional functions that we can now define because we've defined +;;; `cl-defsubst' and `cl-typep'. + +(cl-defsubst cl-struct-slot-value (struct-type slot-name inst) + ;; The use of `cl-defsubst' here gives us both a compiler-macro + ;; and a gv-expander "for free". + "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)) + (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) 'vector) + (aref inst (cl-struct-slot-offset struct-type slot-name)) + (nth (cl-struct-slot-offset struct-type slot-name) inst))) (run-hooks 'cl-macs-load-hook) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index aa88264c4ab..a7078328748 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -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)) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index b5b6566cf66..9a17a75e48b 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -300,7 +300,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. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 892fa7f2d37..473edb4bc61 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -410,12 +410,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: @@ -433,10 +428,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. @@ -567,16 +559,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 @@ -721,8 +710,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) @@ -730,7 +719,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 @@ -826,14 +815,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) @@ -877,7 +863,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) @@ -1048,16 +1034,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)) @@ -1076,7 +1061,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))) @@ -1084,7 +1069,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 @@ -3209,7 +3194,7 @@ function or macro is called, Edebug will be called there as well." (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)))) @@ -3237,25 +3222,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)))) @@ -3399,9 +3373,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 @@ -4136,9 +4108,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 150724e6484..a1c2cb54a9e 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -1,4 +1,4 @@ -;;; eieio-base.el --- Base classes for EIEIO. +;;; eieio-base.el --- Base classes for EIEIO. -*- lexical-binding:t -*- ;;; Copyright (C) 2000-2002, 2004-2005, 2007-2014 Free Software ;;; Foundation, Inc. @@ -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 ;; @@ -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) +(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) @@ -118,7 +119,7 @@ a variable symbol used to store a list of all instances." :abstract t) (defmethod initialize-instance :AFTER ((this eieio-instance-tracker) - &rest slots) + &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. @@ -154,7 +155,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) +(defmethod constructor :STATIC ((class eieio-singleton) _name &rest _slots) "Constructor for singleton CLASS. NAME and SLOTS initialize the new object. This constructor guarantees that no matter how many you request, diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 76655caf65a..2897ce9042a 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -1,4 +1,4 @@ -;;; eieio-core.el --- Core implementation for eieio +;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*- ;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc. @@ -31,21 +31,7 @@ ;;; 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)) - - ) +(require 'cl-lib) (put 'eieio--defalias 'byte-hunk-handler #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) @@ -117,12 +103,12 @@ default setting for optimization purposes.") (defmacro eieio--with-scoped-class (class &rest forms) "Set CLASS as the currently scoped class while executing FORMS." + (declare (indent 1)) `(unwind-protect (progn (push ,class eieio--scoped-class-stack) ,@forms) (pop eieio--scoped-class-stack))) -(put 'eieio--with-scoped-class 'lisp-indent-function 1) ;;; ;; Field Accessors @@ -220,14 +206,14 @@ Stored outright without modifications or stripping."))) ;; 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. +(defsubst class-p (class) + "Return non-nil 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))) + (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) @@ -251,11 +237,11 @@ CLASS is a symbol." "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. +(defsubst generic-p (method) + "Return non-nil 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))) + (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. @@ -298,19 +284,18 @@ Methods with only primary implementations are executed in an optimized way." Return nil if that option doesn't exist." `(class-option-assoc (eieio--class-options (class-v ,class)) ',option)) -(defmacro eieio-object-p (obj) +(defsubst 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))) + (condition-case nil + (and (eq (aref obj 0) 'object) + (class-p (eieio--object-class obj))) + (error nil))) (defalias 'object-p 'eieio-object-p) -(defmacro class-abstract-p (class) +(defsubst class-abstract-p (class) "Return non-nil if CLASS is abstract. Abstract classes cannot be instantiated." - `(class-option ,class :abstract)) + (class-option class :abstract)) (defmacro class-method-invocation-order (class) "Return the invocation order of CLASS. @@ -408,6 +393,12 @@ It creates an autoload function for CNAME's constructor." (when (eq (car-safe (symbol-function cname)) 'autoload) (load-library (car (cdr (symbol-function cname)))))) +(cl-deftype list-of (elem-type) + `(and list + (satisfies (lambda (list) + (cl-every (lambda (elem) (cl-typep elem ',elem-type)) + list))))) + (defun eieio-defclass (cname superclasses slots options-and-doc) ;; FIXME: Most of this should be moved to the `defclass' macro. "Define CNAME as a new subclass of SUPERCLASSES. @@ -476,7 +467,7 @@ See `defclass' for more information." (setf (eieio--class-children (class-v (car pname))) (cons cname (eieio--class-children (class-v (car pname)))))) ;; Get custom groups, and store them into our local copy. - (mapc (lambda (g) (pushnew g groups :test #'equal)) + (mapc (lambda (g) (cl-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)))) @@ -553,8 +544,7 @@ See `defclass' for more information." ;; 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. + ;; FIXME: It would be cleaner to use `cl-deftype' here. (put cname 'cl-deftype-handler (list 'lambda () `(list 'satisfies (quote ,csym))))) @@ -655,7 +645,7 @@ See `defclass' for more information." 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) + (mapc (lambda (cg) (cl-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 @@ -673,26 +663,12 @@ See `defclass' for more information." ;; 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--)))))))) + ;; 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))))) ;; If a writer is defined, then create a generic method of that ;; name whose purpose is to set the value of the slot. @@ -721,7 +697,7 @@ See `defclass' for more information." (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)))) + (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))) @@ -732,11 +708,11 @@ See `defclass' for more information." ;; 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))) + (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))) + (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 @@ -779,7 +755,7 @@ See `defclass' for more information." (fset cname `(lambda (newname &rest slots) ,(format "Create a new object with name NAME of class type %s" cname) - (apply 'constructor ,cname newname slots))) + (apply #'constructor ,cname newname slots))) ) ;; Set up a specialized doc string. @@ -798,7 +774,7 @@ See `defclass' for more information." ;; 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) + (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))))) @@ -1065,7 +1041,7 @@ if default value is nil." )) )) -(defun eieio-copy-parents-into-subclass (newc parents) +(defun eieio-copy-parents-into-subclass (newc _parents) "Copy into NEWC the slots of PARENTS. Follow the rules of not overwriting early parents when applying to the new child class." @@ -1178,6 +1154,8 @@ DOC-STRING is the documentation attached to METHOD." (let ((doc-string (documentation method))) (fset method (eieio-defgeneric-form-primary-only method doc-string)))) +(declare-function no-applicable-method "eieio" (object method &rest args)) + (defun eieio-defgeneric-form-primary-only-one (method doc-string class impl @@ -1212,7 +1190,7 @@ IMPL is the symbol holding the method implementation." ',class))) ;; If not the right kind of object, call no applicable - (apply 'no-applicable-method (car local-args) + (apply #'no-applicable-method (car local-args) ',method local-args) ;; It is ok, do the call. @@ -1299,53 +1277,12 @@ but remove reference to all implementations of METHOD." ;; This is a hideous hack for replacing `typep' from cl-macs, to avoid ;; requiring the CL library at run-time. It can be eliminated if/when ;; `typep' is merged into Emacs core. -(defun eieio--typep (val type) - (if (symbolp type) - (cond ((get type 'cl-deftype-handler) - (eieio--typep val (funcall (get type 'cl-deftype-handler)))) - ((eq type t) t) - ((eq type 'null) (null val)) - ((eq type 'atom) (atom val)) - ((eq type 'float) (and (numberp val) (not (integerp val)))) - ((eq type 'real) (numberp val)) - ((eq type 'fixnum) (integerp val)) - ((memq type '(character string-char)) (characterp val)) - (t - (let* ((name (symbol-name type)) - (namep (intern (concat name "p")))) - (if (fboundp namep) - (funcall `(lambda () (,namep val))) - (funcall `(lambda () - (,(intern (concat name "-p")) val))))))) - (cond ((get (car type) 'cl-deftype-handler) - (eieio--typep val (apply (get (car type) 'cl-deftype-handler) - (cdr type)))) - ((memq (car type) '(integer float real number)) - (and (eieio--typep val (car type)) - (or (memq (cadr type) '(* nil)) - (if (consp (cadr type)) - (> val (car (cadr type))) - (>= val (cadr type)))) - (or (memq (caddr type) '(* nil)) - (if (consp (car (cddr type))) - (< val (caar (cddr type))) - (<= val (car (cddr type))))))) - ((memq (car type) '(and or not)) - (eval (cons (car type) - (mapcar (lambda (x) - `(eieio--typep (quote ,val) (quote ,x))) - (cdr type))))) - ((memq (car type) '(member member*)) - (memql val (cdr type))) - ((eq (car type) 'satisfies) - (funcall `(lambda () (,(cadr type) val)))) - (t (error "Bad type spec: %s" type))))) (defun eieio-perform-slot-validation (spec value) "Return non-nil if SPEC does not match VALUE." (or (eq spec t) ; t always passes (eq value eieio-unbound) ; unbound always passes - (eieio--typep value spec))) + (cl-typep value spec))) (defun eieio-validate-slot-value (class slot-idx value slot) "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. @@ -1632,7 +1569,7 @@ If a consistent order does not exist, signal an error." ;; applicable. (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)))))) @@ -1700,7 +1637,7 @@ The order, in which the parents are returned depends on the method invocation orders of the involved classes." (if (or (null class) (eq class 'eieio-default-superclass)) nil - (case (class-method-invocation-order class) + (cl-case (class-method-invocation-order class) (:depth-first (eieio-class-precedence-dfs class)) (:breadth-first @@ -1839,7 +1776,7 @@ This should only be called from a generic function." ;; 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)) + (let ((rval nil) (lastval nil) (found nil)) (while lambdas (if (car lambdas) (eieio--with-scoped-class (cdr (car lambdas)) @@ -1856,20 +1793,16 @@ This should only be called from a generic function." ;;(setq rval (apply (car (car lambdas)) newargs)) (setq lastval (apply (car (car lambdas)) newargs)) (when has-return-val - (setq rval lastval - rvalever t)) + (setq rval lastval)) ))) (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) + (setq rval (apply #'no-applicable-method (car args) method args)) (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) @@ -1920,7 +1853,7 @@ for this common case to improve performance." ;; 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) + (let* ((rval nil) (lastval nil) (eieio-generic-call-key method-primary) ;; Use the cdr, as the first element is the fcn ;; we are calling right now. @@ -1931,8 +1864,8 @@ for this common case to improve performance." ;; No methods found for this impl... (if (eieio-object-p (car args)) - (setq rval (apply 'no-applicable-method (car args) method args) - rvalever t) + (setq rval (apply #'no-applicable-method + (car args) method args)) (signal 'no-method-definition (list method args))) @@ -1943,12 +1876,8 @@ for this common case to improve performance." lambdas) (setq lastval (apply (car lambdas) newargs)) - (setq rval lastval - rvalever t) - ) + (setq rval lastval)) - ;; Right Here... it could be that lastval is returned when - ;; rvalever is nil. Is that right? rval)))) (defun eieiomt-method-list (method key class) @@ -2054,7 +1983,7 @@ CLASS is the class this method is associated with." (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) + (cl-pushnew (list class fname) loc :test 'equal) (put method-name 'method-locations loc))) ;; Now optimize the entire obarray (if (< key method-num-lists) @@ -2084,7 +2013,8 @@ nil for superclasses. This function performs no type checking!" ;; 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))) + (dolist (ancestor + (cl-rest (eieio-class-precedence-list external-symbol))) (let ((ov (intern-soft (symbol-name ancestor) eieiomt-optimizing-obarray))) (when (fboundp ov) @@ -2140,30 +2070,12 @@ is memorized for faster future use." ;;; 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") +(define-error 'no-method-definition "No method definition") +(define-error 'no-next-method "No next method") +(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") ;;; Obsolete backward compatibility functions. ;; Needed to run byte-code compiled with the EIEIO of Emacs-23. diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index cbb35fee3f6..df153eefd0e 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -383,7 +383,7 @@ 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)) "Insert an Apply and Reset button into the object editor. diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index ca9b91bed58..6f1d01c211f 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -356,7 +356,7 @@ are not abstract." (insert "' " (aref prefix i) " ") ;; argument list (let* ((func (cdr (car gm))) - (arglst (eieio-lambda-arglist func))) + (arglst (help-function-arglist func))) (prin1 arglst (current-buffer))) (insert "\n" (or (documentation (cdr (car gm))) @@ -374,13 +374,6 @@ are not abstract." (insert "\n"))) (setq i (1+ i))))))) -(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 @@ -419,15 +412,15 @@ function has no documentation, then return nil." (fboundp after))) nil (list (if (fboundp before) - (cons (eieio-lambda-arglist before) + (cons (help-function-arglist before) (documentation before)) nil) (if (fboundp primary) - (cons (eieio-lambda-arglist primary) + (cons (help-function-arglist primary) (documentation primary)) nil) (if (fboundp after) - (cons (eieio-lambda-arglist after) + (cons (help-function-arglist after) (documentation after)) nil)))))) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 23cf5197233..c8330d5b695 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -1,4 +1,4 @@ -;;; 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-2014 Free Software Foundation, Inc. @@ -44,8 +44,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! - (defvar eieio-version "1.4" "Current version of EIEIO.") @@ -115,6 +113,7 @@ 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'." + (declare (doc-string 4)) ;; 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 @@ -155,7 +154,7 @@ a string." ;;; CLOS methods and generics ;; -(defmacro defgeneric (method args &optional doc-string) +(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 @@ -163,6 +162,7 @@ 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)) `(eieio--defalias ',method (eieio--defgeneric-init-form ',method ,doc-string))) @@ -191,6 +191,7 @@ Summary: ((typearg class-name) arg2 &optional opt &rest rest) \"doc-string\" body)" + (declare (doc-string 3)) (let* ((key (if (keywordp (car args)) (pop args))) (params (car args)) (arg1 (car params)) @@ -246,6 +247,7 @@ 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)) + (require 'cl-lib) ;; Transform the spec-list into a cl-symbol-macrolet spec-list. (let ((mappings (mapcar (lambda (entry) (let ((var (if (listp entry) (car entry) entry)) @@ -523,7 +525,7 @@ Use `next-method-p' to find out if there is a next method to call." (next (car eieio-generic-call-next-method-list)) ) (if (or (not next) (not (car next))) - (apply 'no-next-method (car newargs) (cdr newargs)) + (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) @@ -535,27 +537,7 @@ Use `next-method-p' to find out if there is a next method to call." ;;; 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)))))) +(gv-define-simple-setter eieio-oref eieio-oset) ;;; @@ -651,7 +633,7 @@ dynamically set from SLOTS." "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) + _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 @@ -684,7 +666,7 @@ EIEIO can only dispatch on the first argument, so the first two are swapped." "Called if there are no implementations for OBJECT in METHOD.") (defmethod no-applicable-method ((object eieio-default-superclass) - method &rest args) + 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. @@ -734,7 +716,7 @@ first and modify the returned object.") (defgeneric destructor (this &rest params) "Destructor for cleaning up any dynamic links to our object.") -(defmethod destructor ((this eieio-default-superclass) &rest params) +(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." @@ -760,7 +742,7 @@ Implement this function and specify STRINGS in a call to `call-next-method' to provide additional summary information. When passing in extra strings from child classes, always remember to prepend a space." - (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.") @@ -859,7 +841,7 @@ 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'." @@ -871,16 +853,19 @@ of `eq'." ;;; 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." + +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 ((class-p object) (eieio-class-name object)) ((eieio-object-p object) (object-print object)) ((and (listp object) (or (class-p (car object)) (eieio-object-p (car object)))) - (concat "(" (mapconcat 'eieio-edebug-prin1-to-string object " ") ")")) - (t (prin1-to-string object noescape)))) + (concat "(" (mapconcat #'eieio-edebug-prin1-to-string object " ") + ")")) + (t (funcall print-function object noescape)))) (add-hook 'edebug-setup-hook (lambda () @@ -904,19 +889,13 @@ Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." (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) - ) - ) + (advice-add 'edebug-prin1-to-string + :around #'eieio-edebug-prin1-to-string))) ;;; Start of automatically extracted autoloads. -;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "5b0e7b1beea11f9e9de6887279f75d61") +;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "ab711689b2bae8a7d8c4b1e99c892306") ;;; Generated autoloads from eieio-custom.el (autoload 'customize-object "eieio-custom" "\ @@ -927,7 +906,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;*** -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "99b94c63a73593402e3c825178a44f4f") +;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "889c0a935dddf758dbb65488470ffa06") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index c64ec52decb..2ee3d23714c 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -1,4 +1,4 @@ -;;; eldoc.el --- show function arglist or variable docstring in echo area -*- lexical-binding: t; -*- +;;; eldoc.el --- Show function arglist or variable docstring in echo area -*- lexical-binding:t; -*- ;; Copyright (C) 1996-2014 Free Software Foundation, Inc. @@ -47,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 @@ -75,18 +73,19 @@ Changing the value requires toggling `eldoc-mode'." :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. @@ -103,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\ @@ -114,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. @@ -127,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, @@ -138,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) @@ -183,15 +185,33 @@ 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 - (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)) + (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))) + (remove-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area t)))) + +;;;###autoload +(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) + (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 (define-obsolete-function-alias 'turn-on-eldoc-mode 'eldoc-mode "24.4") @@ -199,11 +219,16 @@ expression point is on." (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)))))) + (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)) @@ -298,8 +323,8 @@ Otherwise work like `message'." ;;;###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. @@ -311,8 +336,7 @@ 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.") +This variable is expected to be set buffer-locally by modes that support ElDoc.") (defun eldoc-print-current-symbol-info () ;; This is run from post-command-hook or some idle timer thing, @@ -323,240 +347,7 @@ Emacs Lisp mode) that support ElDoc.") (when eldoc-last-message (eldoc-message nil) nil)) - (if eldoc-documentation-function - (eldoc-message (funcall eldoc-documentation-function)) - (let* ((current-symbol (eldoc-current-symbol)) - (current-fnsym (eldoc-fnsym-in-current-sexp)) - (doc (cond - ((null current-fnsym) - nil) - ((eq current-symbol (car current-fnsym)) - (or (apply 'eldoc-get-fnsym-args-string - current-fnsym) - (eldoc-get-var-docstring current-symbol))) - (t - (or (eldoc-get-var-docstring current-symbol) - (apply 'eldoc-get-fnsym-args-string - current-fnsym)))))) - (eldoc-message doc)))))) - -(defun eldoc-get-fnsym-args-string (sym &optional index) - "Return a string containing the parameter list of the function SYM. -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)))))))) - -;; 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 _ - (progn - ;; First account for the case the point is directly over a - ;; beginning of a nested sexp. - (condition-case _ - (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 (symbol-function fsym))) - (and (symbolp defn) - (condition-case _ - (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) " ")) + (eldoc-message (funcall eldoc-documentation-function))))) ;; When point is in a sexp, the function args are not reprinted in the echo @@ -573,7 +364,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) @@ -583,7 +374,7 @@ 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)))) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 34041aab9a8..024110b93e0 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1320,7 +1320,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) @@ -1463,6 +1463,65 @@ 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 () diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 5c404ce0468..e1586a96716 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -178,8 +178,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.") @@ -312,6 +311,39 @@ The search is done in the source for library LIBRARY." (cons (current-buffer) (point))) (cons (current-buffer) nil)))))))) +(defun find-function-library (function &optional lisp-only verbose) + "Return the library FUNCTION is defined in. + +If 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 (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) + (not verbose) + (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)) + (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 +362,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 ((library (find-function-library function lisp-only t))) + (find-function-search-for-symbol function nil library))) (defun find-function-read (&optional type) "Read and return an interned symbol, defaulting to the one near point. diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el deleted file mode 100644 index d0a89b3075a..00000000000 --- a/lisp/emacs-lisp/gulp.el +++ /dev/null @@ -1,178 +0,0 @@ -;;; gulp.el --- ask for updates for Lisp packages - -;; Copyright (C) 1996, 2001-2014 Free Software Foundation, Inc. - -;; Author: Sam Shteingold <shteingd@math.ucla.edu> -;; Maintainer: emacs-devel@gnu.org -;; 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\\|emacs-devel@gnu\\.org\\) *$" - "The regexp matching the packages not requiring the request for updates." - :version "24.4" ; added emacs-devel - :type 'regexp - :group 'gulp) - -(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 692b76e8a36..a0f92a5f94a 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -89,10 +89,10 @@ DO must return an Elisp expression." (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. @@ -357,6 +357,34 @@ The return value is the last VAL in the list. (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. ;; While several of the "places" below are not terribly useful for direct use, @@ -479,22 +507,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/inline.el b/lisp/emacs-lisp/inline.el new file mode 100644 index 00000000000..679e875e1a0 --- /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 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/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 1cdba5b371a..d84113b418a 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -33,17 +33,10 @@ (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) @@ -82,13 +75,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) @@ -102,25 +93,35 @@ It has `lisp-mode-abbrev-table' as its parent." (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-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)) + ;; CLOS and EIEIO + "defgeneric" "defmethod") + t)) "\\s-+\\(\\(\\sw\\|\\s_\\)+\\)")) 2) (list (purecopy "Variables") (purecopy (concat "^\\s-*(" (eval-when-compile (regexp-opt - '("defconst" "defconstant" "defcustom" - "defparameter" "define-symbol-macro") t)) + '(;; Elisp + "defconst" "defcustom" + ;; CL + "defconstant" + "defparameter" "define-symbol-macro") + t)) "\\s-+\\(\\(\\sw\\|\\s_\\)+\\)")) 2) ;; For `defvar', we ignore (defvar FOO) constructs. @@ -132,10 +133,16 @@ It has `lisp-mode-abbrev-table' as its parent." (purecopy (concat "^\\s-*(" (eval-when-compile (regexp-opt - '("defgroup" "deftheme" "deftype" "defstruct" - "defclass" "define-condition" "define-widget" - "defface" "defpackage" "cl-deftype" - "cl-defstruct") t)) + '(;; Elisp + "defgroup" "deftheme" + "define-widget" "define-error" + "defface" "cl-deftype" "cl-defstruct" + ;; CL + "deftype" "defstruct" + "define-condition" "defpackage" + ;; CLOS and EIEIO + "defclass") + t)) "\\s-+'?\\(\\(\\sw\\|\\s_\\)+\\)")) 2)) @@ -156,6 +163,24 @@ It has `lisp-mode-abbrev-table' as its parent." ;;;; 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)) + (pcase-let ((`(,vdefs ,tdefs ,el-defs-re ,cl-defs-re @@ -170,7 +195,7 @@ It has `lisp-mode-abbrev-table' as its parent." "ignore-errors" "dotimes" "dolist" "declare")) (lisp-errs '("warn" "error" "signal")) ;; Elisp constructs. FIXME: update dynamically from obarray. - (el-fdefs '("defadvice" "defalias" + (el-fdefs '("define-advice" "defadvice" "defalias" "define-derived-mode" "define-minor-mode" "define-generic-mode" "define-global-minor-mode" "define-globalized-minor-mode" "define-skeleton" @@ -178,9 +203,9 @@ It has `lisp-mode-abbrev-table' as its parent." (el-vdefs '("defconst" "defcustom" "defvaralias" "defvar-local" "defface")) (el-tdefs '("defgroup" "deftheme")) - (el-kw '("while-no-input" "letrec" "pcase" "pcase-let" - "pcase-let*" "save-restriction" "save-excursion" - "save-selected-window" + (el-kw '("while-no-input" "letrec" "pcase" "pcase-exhaustive" + "pcase-let" "pcase-let*" "save-restriction" + "save-excursion" "save-selected-window" ;; "eval-after-load" "eval-next-after-load" "save-window-excursion" "save-current-buffer" "save-match-data" "combine-after-change-calls" @@ -189,6 +214,7 @@ It has `lisp-mode-abbrev-table' as its parent." "with-category-table" "with-coding-priority" "with-current-buffer" "with-demoted-errors" "with-electric-help" "with-eval-after-load" + "with-file-modes" "with-local-quit" "with-no-warnings" "with-output-to-temp-buffer" "with-selected-window" "with-selected-frame" "with-silent-modifications" @@ -207,7 +233,7 @@ It has `lisp-mode-abbrev-table' as its parent." "etypecase" "ccase" "ctypecase" "loop" "do" "do*" "the" "locally" "proclaim" "declaim" "letf" "go" ;; "lexical-let" "lexical-let*" - "symbol-macrolet" "flet" "destructuring-bind" + "symbol-macrolet" "flet" "flet*" "destructuring-bind" "labels" "macrolet" "tagbody" "multiple-value-bind" "block" "return" "return-from")) (cl-lib-errs '("assert" "check-type")) @@ -347,6 +373,9 @@ It has `lisp-mode-abbrev-table' as its parent." ;; 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.") @@ -377,6 +406,9 @@ It has `lisp-mode-abbrev-table' as its parent." ;; 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.")) @@ -387,6 +419,41 @@ It has `lisp-mode-abbrev-table' as its parent." (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 "([ \t\n]*\\(\\(\\sw\\|\\s_\\)+\\)") + (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. @@ -394,32 +461,9 @@ 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)) @@ -465,10 +509,10 @@ font-lock keywords will not be case sensitive." 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) - ;; electric (when elisp (setq-local electric-pair-text-pairs (cons '(?\` . ?\') electric-pair-text-pairs))) @@ -520,166 +564,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 '(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) @@ -695,72 +579,6 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") (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}" - :group 'lisp - (lisp-mode-variables nil nil 'elisp) - (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 @@ -814,421 +632,6 @@ or to switch back to an existing one." (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}" - :abbrev-table nil) - -(defun eval-print-last-sexp (&optional eval-last-sexp-arg-internal) - "Evaluate sexp before point; print value into current buffer. - -Normally, this function truncates long output according to the value -of the variables `eval-expression-print-length' and -`eval-expression-print-level'. With a prefix argument of zero, -however, there is no such truncation. Such a prefix argument -also causes integers to be printed in several additional formats -\(octal, hexadecimal, and character). - -If `eval-expression-debug-on-error' is non-nil, which is the default, -this command arranges for all errors to enter the debugger." - (interactive "P") - (let ((standard-output (current-buffer))) - (terpri) - (eval-last-sexp (or eval-last-sexp-arg-internal 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. -With a zero prefix arg, print output with no limit on the length -and level of lists, and include additional formats for integers -\(octal, hexadecimal, and character)." - (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) - ;; Setup the lexical environment if lexical-binding is enabled. - (eval-last-sexp-print-value - (eval (eval-sexp-add-defvars (preceding-sexp)) lexical-binding) - eval-last-sexp-arg-internal))) - - -(defun eval-last-sexp-print-value (value &optional eval-last-sexp-arg-internal) - (let ((unabbreviated (let ((print-length nil) (print-level nil)) - (prin1-to-string value))) - (print-length (and (not (zerop (prefix-numeric-value - eval-last-sexp-arg-internal))) - eval-expression-print-length)) - (print-level (and (not (zerop (prefix-numeric-value - eval-last-sexp-arg-internal))) - eval-expression-print-level)) - (beg (point)) - end) - (prog1 - (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. - -Normally, this function truncates long output according to the value -of the variables `eval-expression-print-length' and -`eval-expression-print-level'. With a prefix argument of zero, -however, there is no such truncation. Such a prefix argument -also causes integers to be printed in several additional formats -\(octal, hexadecimal, and character). - -If `eval-expression-debug-on-error' is non-nil, which is the default, -this command arranges for all errors to enter the debugger." - (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. - (let ((standard-output t) - beg end form) - ;; Read the form from the buffer, and record where it ends. - (save-excursion - (end-of-defun) - (beginning-of-defun) - (setq beg (point)) - (setq form (read (current-buffer))) - (setq end (point))) - ;; Alter the form if necessary. - (let ((form (eval-sexp-add-defvars - (eval-defun-1 (macroexpand form))))) - (eval-region beg end standard-output - (lambda (_ignore) - ;; Skipping to the end of the specified region - ;; will make eval-region return. - (goto-char end) - form)))))) - (let ((str (eval-expression-print-format (car values)))) - (if str (princ str))) - ;; The result of evaluation has been put onto VALUES. So return it. - (car values)) - -(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") @@ -1551,19 +954,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 a7de1bd255e..31682d036bf 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -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 @@ -140,38 +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. This command will also work on other parentheses-like expressions -defined by the current language mode. -With ARG, do this that many times. -A negative argument means move forward but still to a less deep spot. -This command assumes point is not in a string or comment." - (interactive "^p") - (up-list (- (or arg 1)))) - -(defun up-list (&optional arg) +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. This command will also work on other parentheses-like expressions -defined by the current language mode. -With ARG, do this that many times. -A negative argument means move backward but still to a less deep spot. -This command assumes point is not in a string or comment." - (interactive "^p") +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) @@ -464,11 +522,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)) @@ -504,6 +566,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)))) @@ -684,248 +758,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))))) - (`(quote . ,_) (setq sexp nil)) - (`(,_ . ,_) - (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 (condition-case nil - (car (read-from-string - (concat txt "lisp--witness--lisp" closer))) - (end-of-file nil))) - (macroexpand-advice (lambda (expander form &rest args) - (condition-case nil - (apply expander form args) - (error form)))) - (sexp - (unwind-protect - (progn - (advice-add 'macroexpand :around macroexpand-advice) - (macroexpand-all sexp)) - (advice-remove 'macroexpand macroexpand-advice))) - (vars (lisp--local-variables-1 nil sexp))) - (delq nil - (mapcar (lambda (var) - (and (symbolp var) - (not (string-match (symbol-name var) "\\`[&_]")) - ;; Eliminate uninterned vars. - (intern-soft var) - var)) - vars)))))) - -(defvar lisp--local-variables-completion-table - ;; Use `defvar' rather than `defconst' since defconst would purecopy this - ;; value, which would doubly fail: it would fail because purecopy can't - ;; handle the recursive bytecode object, and it would fail because it would - ;; move `lastpos' and `lastvars' to pure space where they'd be immutable! - (let ((lastpos nil) (lastvars nil)) - (letrec ((hookfun (lambda () - (setq lastpos nil) - (remove-hook 'post-command-hook hookfun)))) - (completion-table-dynamic - (lambda (_string) - (save-excursion - (skip-syntax-backward "_w") - (let ((newpos (cons (point) (current-buffer)))) - (unless (equal lastpos newpos) - (add-hook 'post-command-hook hookfun) - (setq lastpos newpos) - (setq lastvars - (mapcar #'symbol-name (lisp--local-variables)))))) - lastvars))))) - -;; FIXME: Support for Company brings in features which straddle eldoc. -;; We should consolidate this, so that major modes can provide all that -;; data all at once: -;; - a function to extract "the reference at point" (may be more complex -;; than a mere string, to distinguish various namespaces). -;; - a function to jump to such a reference. -;; - a function to show the signature/interface of such a reference. -;; - a function to build a help-buffer about that reference. -;; FIXME: Those functions should also be used by the normal completion code in -;; the *Completions* buffer. - -(defun lisp--company-doc-buffer (str) - (let ((symbol (intern-soft str))) - ;; FIXME: we really don't want to "display-buffer and then undo it". - (save-window-excursion - ;; Make sure we don't display it in another frame, otherwise - ;; save-window-excursion won't be able to undo it. - (let ((display-buffer-overriding-action - '(nil . ((inhibit-switch-frame . t))))) - (ignore-errors - (cond - ((fboundp symbol) (describe-function symbol)) - ((boundp symbol) (describe-variable symbol)) - ((featurep symbol) (describe-package symbol)) - ((facep symbol) (describe-face symbol)) - (t (signal 'user-error nil))) - (help-buffer)))))) - -(defun lisp--company-doc-string (str) - (let* ((symbol (intern-soft str)) - (doc (if (fboundp symbol) - (documentation symbol t) - (documentation-property symbol 'variable-documentation t)))) - (and (stringp doc) - (string-match ".*$" doc) - (match-string 0 doc)))) - -(declare-function find-library-name "find-func" (library)) - -(defun lisp--company-location (str) - (let ((sym (intern-soft str))) - (cond - ((fboundp sym) (find-definition-noselect sym nil)) - ((boundp sym) (find-definition-noselect sym 'defvar)) - ((featurep sym) - (require 'find-func) - (cons (find-file-noselect (find-library-name - (symbol-name sym))) - 0)) - ((facep sym) (find-definition-noselect sym 'defface))))) - -(defun lisp-completion-at-point (&optional _predicate) - "Function used for `completion-at-point-functions' in `emacs-lisp-mode'." - (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)) - '(?\s ?\" ?\( ?\)))) - (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-merge - lisp--local-variables-completion-table - (apply-partially #'completion-table-with-predicate - obarray - ;; Don't include all symbols - ;; (bug#16646). - (lambda (sym) - (or (boundp sym) - (fboundp sym) - (symbol-plist sym))) - 'strict)) - :annotation-function - (lambda (str) (if (fboundp (intern-soft str)) " <f>")) - :company-doc-buffer #'lisp--company-doc-buffer - :company-docsig #'lisp--company-doc-string - :company-location #'lisp--company-location) - ;; Looks like a funcall position. Let's double check. - (save-excursion - (goto-char (1- beg)) - (let ((parent - (condition-case nil - (progn (up-list -1) (forward-char 1) - (let ((c (char-after))) - (if (eq c ?\() ?\( - (if (memq (char-syntax c) '(?w ?_)) - (read (current-buffer)))))) - (error nil)))) - (pcase parent - ;; FIXME: Rather than hardcode special cases here, - ;; we should use something like a symbol-property. - (`declare - (list t (mapcar (lambda (x) (symbol-name (car x))) - (delete-dups - ;; FIXME: We should include some - ;; docstring with each entry. - (append - macro-declarations-alist - defun-declarations-alist))))) - ((and (or `condition-case `condition-case-unless-debug) - (guard (save-excursion - (ignore-errors - (forward-sexp 2) - (< (point) beg))))) - (list t obarray - :predicate (lambda (sym) (get sym 'error-conditions)))) - ((and ?\( - (guard (save-excursion - (goto-char (1- beg)) - (up-list -1) - (forward-symbol -1) - (looking-at "\\_<let\\*?\\_>")))) - (list t obarray - :predicate #'boundp - :company-doc-buffer #'lisp--company-doc-buffer - :company-docsig #'lisp--company-doc-string - :company-location #'lisp--company-location)) - (_ (list nil obarray - :predicate #'fboundp - :company-doc-buffer #'lisp--company-doc-buffer - :company-docsig #'lisp--company-doc-string - :company-location #'lisp--company-location - )))))))) - (when end - (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 e3a746fa69e..b40e44ee90f 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -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) @@ -144,11 +144,35 @@ and also to avoid outputting the warning during normal execution." (instead (format "; 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--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 @@ -225,6 +249,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 +266,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) @@ -316,6 +344,15 @@ be skipped; if nil, as is usual, `macroexp-const-p' is used." (macroexp-let* (list (list ,var ,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 +404,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 +451,7 @@ symbol itself." (defvar macroexp--pending-eager-loads nil "Stack of files currently undergoing eager macro-expansion.") -(defun internal-macroexpand-for-load (form) +(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. @@ -425,7 +474,9 @@ symbol itself." (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/nadvice.el b/lisp/emacs-lisp/nadvice.el index 1c8641249cf..a81d3e43de3 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -236,11 +236,12 @@ 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))))) -(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))) +(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) @@ -440,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 diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 823ba365e62..80b7670c1f0 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -162,8 +162,10 @@ ;;; Code: (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." @@ -289,6 +291,8 @@ contrast, `package-user-dir' contains packages for personal use." :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) @@ -512,7 +516,11 @@ 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-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-dir (file-name-as-directory pkg-dir))) @@ -520,15 +528,27 @@ Return the max version (as a string) if the package is held at a lower version." (error "Internal error: unable to find directory for `%s'" (package-desc-full-name pkg-desc))) ;; Add to load path, add autoloads, and activate the package. - (let ((old-lp load-path)) - (with-demoted-errors - (load (expand-file-name (format "%s-autoloads" name) pkg-dir) nil t)) + (let* ((old-lp load-path) + (autoloads-file (expand-file-name + (format "%s-autoloads" name) pkg-dir)) + (loaded-files-list (and reload (package--list-loaded-files pkg-dir)))) + (with-demoted-errors "Error in package-activate-1: %s" + (load autoloads-file 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))) + (push pkg-dir load-path)) + ;; 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 autoloads-file) loaded-files-list)))) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -539,6 +559,41 @@ Return the max version (as a string) if the package is held at a lower version." ;; Don't return nil. t)) +(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)))))))) + (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 @@ -588,14 +643,14 @@ 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'. 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))))))) + (package-activate-1 pkg-vec force))))))) (defun define-package (_name-string _version-string &optional _docstring _requirements @@ -659,6 +714,7 @@ EXTRA-PROPERTIES is currently unused." (let* ((auto-name (format "%s-autoloads.el" name)) ;;(ignore-name (concat name "-pkg.el")) (generated-autoload-file (expand-file-name auto-name pkg-dir)) + (backup-inhibited t) (version-control 'never)) (package-autoload-ensure-default-file generated-autoload-file) (update-directory-autoloads pkg-dir) @@ -698,6 +754,7 @@ untar into a directory named DIR; otherwise, signal an error." (print-length nil)) (write-region (concat + ";;; -*- no-byte-compile: t -*-\n" (prin1-to-string (nconc (list 'define-package @@ -718,15 +775,9 @@ untar into a directory named DIR; otherwise, signal an error." nil pkg-file nil 'silent)))) (defun package--alist-to-plist-args (alist) - (mapcar (lambda (x) - (if (and (not (consp x)) - (or (keywordp x) - (not (symbolp x)) - (memq x '(nil t)))) - x `',x)) + (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)) @@ -806,13 +857,24 @@ buffer is killed afterwards. Return the last value in BODY." cipher-algorithm digest-algorithm compress-algorithm)) -(declare-function epg-context-set-home-directory "epg" (context directory)) (declare-function epg-verify-string "epg" (context signature &optional signed-text)) (declare-function epg-context-result-for "epg" (context name)) (declare-function epg-signature-status "epg" (signature)) (declare-function epg-signature-to-string "epg" (signature)) +(defun package--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)))))) + (defun package--check-signature (location file) "Check signature of the current buffer. GnuPG keyring is located under \"gnupg\" in `package-user-dir'." @@ -821,8 +883,12 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'." (sig-file (concat file ".sig")) (sig-content (package--with-work-buffer location sig-file (buffer-string)))) - (epg-context-set-home-directory context homedir) - (epg-verify-string context sig-content (buffer-string)) + (setf (epg-context-home-directory context) homedir) + (condition-case error + (epg-verify-string context sig-content (buffer-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. @@ -836,12 +902,10 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'." (unless (and (eq package-check-signature 'allow-unsigned) (eq (epg-signature-status sig) 'no-pubkey)) (setq had-fatal-error t)))) - (if (and (null good-signatures) had-fatal-error) - (error "Failed to verify signature %s: %S" - sig-file - (mapcar #'epg-signature-to-string - (epg-context-result-for context 'verify))) - good-signatures)))) + (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-install-from-archive (pkg-desc) "Download and install a tar package." @@ -1298,14 +1362,9 @@ similar to an entry in `package-alist'. Save the cached copy to (setq file (expand-file-name file)) (let ((context (epg-make-context 'OpenPGP)) (homedir (expand-file-name "gnupg" package-user-dir))) - ;; FIXME Use `with-file-modes' when merged to trunk. - (let ((umask (default-file-modes))) - (unwind-protect - (progn - (set-default-file-modes 448) - (make-directory homedir t)) - (set-default-file-modes umask))) - (epg-context-set-home-directory context homedir) + (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)))) @@ -1650,7 +1709,7 @@ Letters do not insert themselves; instead, they are commands. \\{package-menu-mode-map}" (setq tabulated-list-format `[("Package" 18 package-menu--name-predicate) - ("Version" 12 nil) + ("Version" 13 nil) ("Status" 10 package-menu--status-predicate) ,@(if (cdr package-archives) '(("Archive" 10 package-menu--archive-predicate))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 2cdb7b4987e..753cd3005e6 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -68,6 +68,8 @@ (defconst pcase--dontcare-upats '(t _ pcase--dontcare)) +(defvar pcase--dontwarn-upats '(pcase--dontcare)) + (def-edebug-spec pcase-UPAT (&or symbolp @@ -100,26 +102,31 @@ UPatterns can take the following forms: 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. + 'VAL matches if the object is `equal' to VAL `QPAT matches if the QPattern QPAT matches. - (pred PRED) matches if PRED applied to the object returns non-nil. + (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. + (app FUN UPAT) matches if FUN applied to the object matches UPAT. If a SYMBOL is used twice in the same pattern (i.e. the pattern is \"non-linear\"), then the second occurrence is turned into an `eq'uality test. QPatterns can take the following forms: - (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. - ,UPAT matches if the UPattern UPAT matches. - STRING matches if the object is `equal' to STRING. - ATOM matches if the object is `eq' to ATOM. -QPatterns for vectors are not implemented yet. - -PRED can take the form - FUNCTION in which case it gets called with one argument. - (FUN ARG1 .. ARGN) in which case it gets called with an N+1'th argument + (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. + ,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. + +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))))" @@ -147,6 +154,16 @@ like `(,a . ,(pred (< a))) or, with more checks: ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2) expansion)))) +;;;###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))))))) + (defun pcase--let* (bindings body) (cond ((null bindings) (macroexp-progn body)) @@ -265,7 +282,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 +296,50 @@ 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 pcase UPattern macro." + (declare (indent 2) (debug (def-name sexp def-body)) (doc-string 3)) + `(put ',name 'pcase-macroexpander + (lambda ,args ,@body))) + +(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 +363,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 @@ -383,21 +435,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 +460,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 +477,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))) ) @@ -467,6 +497,7 @@ MATCH is the pattern that needs to be matched, of the form: '(: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 @@ -474,10 +505,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))) ) @@ -508,7 +539,7 @@ 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) ((vectorp (cadr pat)) #'vectorp) ((byte-code-function-p (cadr pat)) @@ -516,7 +547,7 @@ MATCH is the pattern that needs to be matched, of the form: (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) @@ -538,10 +569,71 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--self-quoting-p (upat) (or (keywordp upat) (numberp upat) (stringp upat))) +(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) @@ -563,22 +655,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 @@ -612,35 +708,11 @@ 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) (pcase--mark-used sym) (if (not (assq upat vars)) @@ -655,57 +727,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 UPAT) (pcase--mark-used sym) - (pcase--q1 sym (cadr upat) matches code vars rest)) - ((eq (car-safe upat) 'or) - (let ((all (> (length (cdr upat)) 1)) - (memq-fine t)) - (when all - (dolist (alt (cdr upat)) - (unless (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. @@ -727,57 +783,25 @@ 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 internal 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)." +(pcase-defmacro \` (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))) (provide 'pcase) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index dd012fab9da..c18b049020a 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -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." @@ -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/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index b2d4f2b71dd..ff9388171a6 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -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 diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el new file mode 100644 index 00000000000..01a3bd3fc50 --- /dev/null +++ b/lisp/emacs-lisp/seq.el @@ -0,0 +1,269 @@ +;;; seq.el --- Sequence manipulation functions -*- lexical-binding: t -*- + +;; Copyright (C) 2014 Free Software Foundation, Inc. + +;; Author: Nicolas Petton <petton.nicolas@gmail.com> +;; Keywords: sequences +;; Version: 1.0 + +;; 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 a function iterating over the +;; sequence 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. +;; +;; All functions are tested in test/automated/seq-tests.el + +;;; Code: + +(defmacro seq-doseq (spec &rest body) + "Loop over a sequence. +Similar to `dolist' but can be applied lists, strings and vectors. + +Evaluate BODY with VAR bound to each element of SEQ, in turn. +Then evaluate RESULT to get return value, default nil. + +\(fn (VAR SEQ [RESULT]) BODY...)" + (declare (indent 1) (debug ((symbolp form &optional form) body))) + (let ((is-list (make-symbol "is-list")) + (seq (make-symbol "seq")) + (index (make-symbol "index"))) + `(let* ((,seq ,(cadr spec)) + (,is-list (listp ,seq)) + (,index (if ,is-list ,seq 0))) + (while (if ,is-list + (consp ,index) + (< ,index (seq-length ,seq))) + (let ((,(car spec) (if ,is-list + (car ,index) + (seq-elt ,seq ,index)))) + ,@body + (setq ,index (if ,is-list + (cdr ,index) + (+ ,index 1))))) + ,@(if (cddr spec) + `((setq ,(car spec) nil) ,@(cddr spec)))))) + +(defun seq-drop (seq n) + "Return a subsequence of SEQ without its first N elements. +The result is a sequence of the same type as SEQ. + +If N is a negative integer or zero, SEQ is returned." + (if (<= n 0) + seq + (if (listp seq) + (seq--drop-list seq n) + (let ((length (seq-length seq))) + (seq-subseq seq (min n length) length))))) + +(defun seq-take (seq n) + "Return a subsequence of SEQ with its first N elements. +The result is a sequence of the same type as SEQ. + +If N is a negative integer or zero, an empty sequence is +returned." + (if (listp seq) + (seq--take-list seq n) + (seq-subseq seq 0 (min (max n 0) (seq-length seq))))) + +(defun seq-drop-while (pred seq) + "Return a sequence, from the first element for which (PRED element) is nil, of SEQ. +The result is a sequence of the same type as SEQ." + (if (listp seq) + (seq--drop-while-list pred seq) + (seq-drop seq (seq--count-successive pred seq)))) + +(defun seq-take-while (pred seq) + "Return a sequence of the successive elements for which (PRED element) is non-nil in SEQ. +The result is a sequence of the same type as SEQ." + (if (listp seq) + (seq--take-while-list pred seq) + (seq-take seq (seq--count-successive pred seq)))) + +(defun seq-filter (pred seq) + "Return a list of all the elements for which (PRED element) is non-nil in SEQ." + (let ((exclude (make-symbol "exclude"))) + (delq exclude (seq-map (lambda (elt) + (if (funcall pred elt) + elt + exclude)) + seq)))) + +(defun seq-remove (pred seq) + "Return a list of all the elements for which (PRED element) is nil in SEQ." + (seq-filter (lambda (elt) (not (funcall pred elt))) + seq)) + +(defun seq-reduce (function seq initial-value) + "Reduce the function FUNCTION across SEQ, starting with INITIAL-VALUE. + +Return the result of calling FUNCTION with INITIAL-VALUE and the +first element of SEQ, then calling FUNCTION with that result and +the second element of SEQ, then with that result and the third +element of SEQ, etc. + +If SEQ is empty, return INITIAL-VALUE and FUNCTION is not called." + (if (seq-empty-p seq) + initial-value + (let ((acc initial-value)) + (seq-doseq (elt seq) + (setq acc (funcall function acc elt))) + acc))) + +(defun seq-some-p (pred seq) + "Return any element for which (PRED element) is non-nil in SEQ, nil otherwise." + (catch 'seq--break + (seq-doseq (elt seq) + (when (funcall pred elt) + (throw 'seq--break elt))) + nil)) + +(defun seq-every-p (pred seq) + "Return non-nil if (PRED element) is non-nil for all elements of the sequence SEQ." + (catch 'seq--break + (seq-doseq (elt seq) + (or (funcall pred elt) + (throw 'seq--break nil))) + t)) + +(defun seq-count (pred seq) + "Return the number of elements for which (PRED element) returns non-nil in seq." + (let ((count 0)) + (seq-doseq (elt seq) + (when (funcall pred elt) + (setq count (+ 1 count)))) + count)) + +(defun seq-empty-p (seq) + "Return non-nil if the sequence SEQ is empty, nil otherwise." + (if (listp seq) + (null seq) + (= 0 (seq-length seq)))) + +(defun seq-sort (pred seq) + "Return a sorted sequence comparing using PRED the elements of SEQ. +The result is a sequence of the same type as SEQ." + (if (listp seq) + (sort (seq-copy seq) pred) + (let ((result (seq-sort pred (append seq nil)))) + (cond ((stringp seq) (concat result)) + ((vectorp seq) (vconcat result)) + (t (error "Unsupported sequence: %s" seq)))))) + +(defun seq-contains-p (seq elt &optional testfn) + "Return the first element in SEQ that equals to ELT. +Equality is defined by TESTFN if non-nil or by `equal' if nil." + (seq-some-p (lambda (e) + (funcall (or testfn #'equal) elt e)) + seq)) + +(defun seq-uniq (seq &optional testfn) + "Return a list of the elements of SEQ with duplicates removed. +TESTFN is used to compare elements, or `equal' if TESTFN is nil." + (let ((result '())) + (seq-doseq (elt seq) + (unless (seq-contains-p result elt testfn) + (setq result (cons elt result)))) + (nreverse result))) + +(defun seq-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." + (cond ((or (stringp seq) (vectorp seq)) (substring seq start end)) + ((listp seq) + (let (len) + (and end (< end 0) (setq end (+ end (setq len (seq-length seq))))) + (if (< start 0) (setq start (+ start (or len (setq len (seq-length 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)) + (seq-copy seq)))) + (t (error "Unsupported sequence: %s" seq)))) + +(defun seq-concatenate (type &rest seqs) + "Concatenate, into a sequence of type TYPE, the sequences SEQS. +TYPE must be one of following symbols: vector, string or list. + +\n(fn TYPE SEQUENCE...)" + (pcase type + (`vector (apply #'vconcat seqs)) + (`string (apply #'concat seqs)) + (`list (apply #'append (append seqs '(nil)))) + (t (error "Not a sequence type name: %s" type)))) + +(defun seq--drop-list (list n) + "Optimized version of `seq-drop' for lists." + (while (and list (> n 0)) + (setq list (cdr list) + n (1- n))) + list) + +(defun seq--take-list (list n) + "Optimized version of `seq-take' for lists." + (let ((result '())) + (while (and list (> n 0)) + (setq n (1- n)) + (push (pop list) result)) + (nreverse result))) + +(defun seq--drop-while-list (pred list) + "Optimized version of `seq-drop-while' for lists." + (while (and list (funcall pred (car list))) + (setq list (cdr list))) + list) + +(defun seq--take-while-list (pred list) + "Optimized version of `seq-take-while' for lists." + (let ((result '())) + (while (and list (funcall pred (car list))) + (push (pop list) result)) + (nreverse result))) + +(defun seq--count-successive (pred seq) + "Return the number of successive elements for which (PRED element) is non-nil in SEQ." + (let ((n 0) + (len (seq-length seq))) + (while (and (< n len) + (funcall pred (seq-elt seq n))) + (setq n (+ 1 n))) + n)) + +(defalias 'seq-copy #'copy-sequence) +(defalias 'seq-elt #'elt) +(defalias 'seq-reverse #'reverse) +(defalias 'seq-length #'length) +(defalias 'seq-do #'mapc) +(defalias 'seq-each #'seq-do) +(defalias 'seq-map #'mapcar) + +(provide 'seq) +;;; seq.el ends here diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 1819daa3df0..ab51e13afcd 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -632,14 +632,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.") @@ -806,9 +806,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) @@ -827,9 +827,9 @@ 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. @@ -1121,7 +1121,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. @@ -2121,41 +2121,45 @@ position corresponding to each rule." otraces) ;; Finally, guess the indentation rules. - (let ((ssigs nil) - (rules nil)) - ;; Sort the sigs by frequency of occurrence. - (maphash (lambda (sig sig-data) (push (cons sig sig-data) ssigs)) sigs) - (setq ssigs (sort ssigs (lambda (sd1 sd2) (> (cadr sd1) (cadr sd2))))) - (while ssigs - (pcase-let ((`(,sig ,total ,off-alist ,cotraces) (pop ssigs))) - (cl-assert (= total (apply #'+ (mapcar #'cdr off-alist)))) - (let* ((sorted-off-alist - (sort off-alist (lambda (x y) (> (cdr x) (cdr y))))) - (offset (caar sorted-off-alist))) - (if (zerop offset) - ;; Nothing to do with this sig; indentation is - ;; correct already. - nil - (push (cons (+ offset (nth 2 sig)) sig) rules) - ;; Adjust the rest of the data. - (pcase-dolist ((and cotrace `(,count ,toffset . ,trace)) - cotraces) - (setf (nth 1 cotrace) (- toffset offset)) - (dolist (sig trace) - (let ((sig-data (cdr (assq sig ssigs)))) - (when sig-data - (let* ((ooff-data (assq toffset (nth 1 sig-data))) - (noffset (- toffset offset)) - (noff-data - (or (assq noffset (nth 1 sig-data)) - (let ((off-data (cons noffset 0))) - (push off-data (nth 1 sig-data)) - off-data)))) - (cl-assert (>= (cdr ooff-data) count)) - (cl-decf (cdr ooff-data) count) - (cl-incf (cdr noff-data) count)))))))))) - (message "Guessing...done") - rules)))) + (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. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 505a556b65f..759760c7d62 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -32,6 +32,113 @@ ;;; 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 ((&rest (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-keys (hash-table) "Return a list of keys in HASH-TABLE." (let ((keys '())) @@ -52,9 +159,7 @@ "Join all STRINGS using SEPARATOR." (mapconcat 'identity strings separator)) -(defsubst string-reverse (str) - "Reverse the string STR." - (apply 'string (nreverse (string-to-list str)))) +(define-obsolete-function-alias 'string-reverse 'reverse "25.1") (defsubst string-trim-left (string) "Remove leading whitespace from STRING." diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 86701068c4e..1e613c7fd4e 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -323,7 +323,8 @@ to the entry with the same ID element as the current line." (if saved-pt (progn (goto-char saved-pt) (move-to-column saved-col) - (recenter)) + (when (eq (window-buffer) (current-buffer)) + (recenter))) (goto-char (point-min))))) (defun tabulated-list-print-entry (id cols) diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 7fc6bf7b920..a189d242ac4 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -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))) @@ -307,8 +305,8 @@ This function is called, by name, directly by the C code." ;; 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)) + (< 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) @@ -374,13 +372,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 @@ -486,7 +484,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) @@ -495,7 +493,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) |