diff options
Diffstat (limited to 'lisp/emacs-lisp')
47 files changed, 4627 insertions, 5846 deletions
diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el deleted file mode 100644 index e20ae9543cd..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-2015 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 d85e9ec43e6..073d923a178 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) @@ -523,7 +539,7 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (autoload-find-file file)) ;; Obey the no-update-autoloads file local variable. (unless no-update-autoloads - (message "Generating autoloads for %s..." file) + (or noninteractive (message "Generating autoloads for %s..." file)) (setq load-name (if (stringp generated-autoload-load-name) generated-autoload-load-name @@ -607,7 +623,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (nth 5 (file-attributes relfile)))) (insert ";;; Generated autoloads from " relfile "\n"))) (insert generate-autoload-section-trailer)))) - (message "Generating autoloads for %s...done" file)) + (or noninteractive + (message "Generating autoloads for %s...done" file))) (or visited ;; We created this buffer, so we should kill it. (kill-buffer (current-buffer)))) diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 4172c1592f8..e3d83eb127f 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-2015 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 5426edc4d2a..082955e0823 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 61729cfde2b..149c4723199 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 c476c049110..caa7e3dad33 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 7be1a3dcbb9..2bd8d07851b 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 (macroexp-macroexpand form byte-compile-macro-environment)) + (if (eq (car-safe form) 'progn) + (cons 'progn + (mapcar (lambda (subform) + (byte-compile-recurse-toplevel + subform non-toplevel-case)) + (cdr form))) + (funcall non-toplevel-case form))) + (defconst byte-compile-initial-macro-environment - '( + `( ;; (byte-compiler-options . (lambda (&rest forms) ;; (apply 'byte-compiler-options-handler forms))) (declare-function . byte-compile-macroexpand-declare-function) - (eval-when-compile . (lambda (&rest body) - (list - 'quote - (byte-compile-eval - (byte-compile-top-level - (byte-compile-preprocess (cons 'progn body))))))) - (eval-and-compile . (lambda (&rest body) - ;; Byte compile before running it. Do it piece by - ;; piece, in case further expressions need earlier - ;; ones to be evaluated already, as is the case in - ;; eieio.el. - `(progn - ,@(mapcar (lambda (exp) - (let ((cexp - (byte-compile-top-level - (byte-compile-preprocess - exp)))) - (eval cexp) - cexp)) - body))))) + (eval-when-compile . ,(lambda (&rest body) + (let ((result nil)) + (byte-compile-recurse-toplevel + (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.") @@ -1837,13 +1858,13 @@ The value is non-nil if there were no errors, nil if errors." ;; recompiled). Previously this was accomplished by ;; deleting target-file before writing it. (rename-file tempfile target-file t) - (message "Wrote %s" target-file)) + (or noninteractive (message "Wrote %s" target-file))) ;; This is just to give a better error message than write-region (signal 'file-error (list "Opening output file" (if (file-exists-p target-file) - "cannot overwrite file" - "directory not writable or nonexistent") + "Cannot overwrite file" + "Directory not writable or nonexistent") target-file))) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree @@ -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 bf7fc6d4345..e9d33e6c646 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/chart.el b/lisp/emacs-lisp/chart.el index 62b2b5cc6da..851b3bfc6fd 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -422,7 +422,7 @@ or is created with the bounds of SEQ." (if (stringp (car (oref seq data))) (let ((labels (oref seq data))) (if (not axis) - (setq axis (make-instance chart-axis-names + (setq axis (make-instance 'chart-axis-names :name (oref seq name) :items labels :chart c)) @@ -430,7 +430,7 @@ or is created with the bounds of SEQ." (let ((range (cons 0 1)) (l (oref seq data))) (if (not axis) - (setq axis (make-instance chart-axis-range + (setq axis (make-instance 'chart-axis-range :name (oref seq name) :chart c))) (while l @@ -577,19 +577,19 @@ labeled NUMTITLE. Optional arguments: Set the chart's max element display to MAX, and sort lists with SORT-PRED if desired." - (let ((nc (make-instance chart-bar + (let ((nc (make-instance 'chart-bar :title title :key-label "8-m" ; This is a text key pic :direction dir )) (iv (eq dir 'vertical))) (chart-add-sequence nc - (make-instance chart-sequece + (make-instance 'chart-sequece :data namelst :name nametitle) (if iv 'x-axis 'y-axis)) (chart-add-sequence nc - (make-instance chart-sequece + (make-instance 'chart-sequece :data numlst :name numtitle) (if iv 'y-axis 'x-axis)) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index e5b64a50b5a..afc2adbee6d 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -38,6 +38,7 @@ ;;; Code: (require 'cl-lib) +(require 'seq) ;;; Type coercion. @@ -269,43 +270,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 +384,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. @@ -508,28 +522,10 @@ If END is omitted, it defaults to the length of the sequence. If START or END is negative, it counts from the end." (declare (gv-setter (lambda (new) - `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) - ,new)))) - (if (stringp seq) (substring seq start end) - (let (len) - (and end (< end 0) (setq end (+ end (setq len (length seq))))) - (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) - (cond ((listp seq) - (if (> start 0) (setq seq (nthcdr start seq))) - (if end - (let ((res nil)) - (while (>= (setq end (1- end)) start) - (push (pop seq) res)) - (nreverse res)) - (copy-sequence seq))) - (t - (or end (setq end (or len (length seq)))) - (let ((res (make-vector (max (- end start) 0) nil)) - (i 0)) - (while (< start end) - (aset res i (aref seq start)) - (setq i (1+ i) start (1+ start))) - res)))))) + (macroexp-let2 nil new new + `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) + ,new))))) + (seq-subseq seq start end)) ;;;###autoload (defun cl-concatenate (type &rest seqs) @@ -575,7 +571,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 +589,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 +629,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-generic.el b/lisp/emacs-lisp/cl-generic.el new file mode 100644 index 00000000000..1bb70963a57 --- /dev/null +++ b/lisp/emacs-lisp/cl-generic.el @@ -0,0 +1,833 @@ +;;; cl-generic.el --- CLOS-style generic functions for Elisp -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This implements the most of CLOS's multiple-dispatch generic functions. +;; To use it you need either (require 'cl-generic) or (require 'cl-lib). +;; The main entry points are: `cl-defgeneric' and `cl-defmethod'. + +;; Missing elements: +;; - We don't support make-method, call-method, define-method-combination. +;; CLOS's define-method-combination is IMO overly complicated, and it suffers +;; from a significant problem: the method-combination code returns a sexp +;; that needs to be `eval'uated or compiled. IOW it requires run-time +;; code generation. Given how rarely method-combinations are used, +;; I just provided a cl-generic-method-combination-function, which +;; people can use if they are really desperate for such functionality. +;; - In defgeneric we don't support the options: +;; declare, :method-combination, :generic-function-class, :method-class, +;; :method. +;; Added elements: +;; - We support aliases to generic functions. +;; - The kind of thing on which to dispatch can be extended. +;; There is support in this file for dispatch on: +;; - (eql <val>) +;; - plain old types +;; - type of CL structs +;; eieio-core adds dispatch on: +;; - class of eieio objects +;; - actual class argument, using the syntax (subclass <class>). +;; - cl-generic-method-combination-function (i.s.o define-method-combination). +;; - cl-generic-call-method (which replaces make-method and call-method). + +;; Efficiency considerations: overall, I've made an effort to make this fairly +;; efficient for the expected case (e.g. no constant redefinition of methods). +;; - Generic functions which do not dispatch on any argument are implemented +;; optimally (just as efficient as plain old functions). +;; - Generic functions which only dispatch on one argument are fairly efficient +;; (not a lot of room for improvement, I think). +;; - Multiple dispatch is implemented rather naively. There's an extra `apply' +;; function call for every dispatch; we don't optimize each dispatch +;; based on the set of candidate methods remaining; we don't optimize the +;; order in which we performs the dispatches either; If/when this +;; becomes a problem, we can try and optimize it. +;; - call-next-method could be made more efficient, but isn't too terrible. + +;;; Code: + +;; Note: For generic functions that dispatch on several arguments (i.e. those +;; which use the multiple-dispatch feature), we always use the same "tagcodes" +;; and the same set of arguments on which to dispatch. This works, but is +;; often suboptimal since after one dispatch, the remaining dispatches can +;; usually be simplified, or even completely skipped. + +;; TODO/FIXME: +;; - WIBNI we could use something like +;; (add-function :before (cl-method-function (cl-find-method ...)) ...) + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'pcase)) + +(defvar cl-generic-tagcode-function + (lambda (type _name) + (if (eq type t) '(0 . 'cl--generic-type) + (error "Unknown specializer %S" type))) + "Function to get the Elisp code to extract the tag on which we dispatch. +Takes a \"parameter-specializer-name\" and a variable name, and returns +a pair (PRIORITY . CODE) where CODE is an Elisp expression that should be +used to extract the \"tag\" (from the object held in the named variable) +that should uniquely determine if we have a match +\(i.e. the \"tag\" is the value that will be used to dispatch to the proper +method(s)). +Such \"tagcodes\" will be or'd together. +PRIORITY is an integer from 0 to 100 which is used to sort the tagcodes +in the `or'. The higher the priority, the more specific the tag should be. +More specifically, if PRIORITY is N and we have two objects X and Y +whose tag (according to TAGCODE) is `eql', then it should be the case +that for all other (PRIORITY . TAGCODE) where PRIORITY ≤ N, then +\(eval TAGCODE) for X is `eql' to (eval TAGCODE) for Y.") + +(defvar cl-generic-tag-types-function + (lambda (tag) (if (eq tag 'cl--generic-type) '(t))) + "Function to get the list of types that a given \"tag\" matches. +They should be sorted from most specific to least specific.") + +(cl-defstruct (cl--generic-method + (:constructor nil) + (:constructor cl--generic-method-make + (specializers qualifiers uses-cnm function)) + (:predicate nil)) + (specializers nil :read-only t :type list) + (qualifiers nil :read-only t :type (list-of atom)) + ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument + ;; holding the next-method. + (uses-cnm nil :read-only t :type boolean) + (function nil :read-only t :type function)) + +(cl-defstruct (cl--generic + (:constructor nil) + (:constructor cl--generic-make + (name &optional dispatches method-table)) + (:predicate nil)) + (name nil :type symbol :read-only t) ;Pointer back to the symbol. + ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index + ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP) + ;; where the EXPs are expressions (to be `or'd together) to compute the tag + ;; on which to dispatch and PRIORITY is the priority of each expression to + ;; decide in which order to sort them. + ;; The most important dispatch is last in the list (and the least is first). + (dispatches nil :type (list-of (cons natnum (list-of tagcode)))) + (method-table nil :type (list-of cl--generic-method))) + +(defmacro cl--generic (name) + `(get ,name 'cl--generic)) + +(defun cl-generic-ensure-function (name) + (let (generic + (origname name)) + (while (and (null (setq generic (cl--generic name))) + (fboundp name) + (symbolp (symbol-function name))) + (setq name (symbol-function name))) + (unless (or (not (fboundp name)) + (autoloadp (symbol-function name)) + (and (functionp name) generic)) + (error "%s is already defined as something else than a generic function" + origname)) + (if generic + (cl-assert (eq name (cl--generic-name generic))) + (setf (cl--generic name) (setq generic (cl--generic-make name))) + (defalias name (cl--generic-make-function generic))) + generic)) + +(defun cl--generic-setf-rewrite (name) + (let* ((setter (intern (format "cl-generic-setter--%s" name))) + (exp `(unless (eq ',setter (get ',name 'cl-generic-setter)) + ;; (when (get ',name 'gv-expander) + ;; (error "gv-expander conflicts with (setf %S)" ',name)) + (setf (get ',name 'cl-generic-setter) ',setter) + (gv-define-setter ,name (val &rest args) + (cons ',setter (cons val args)))))) + ;; Make sure `setf' can be used right away, e.g. in the body of the method. + (eval exp t) + (cons setter exp))) + +;;;###autoload +(defmacro cl-defgeneric (name args &rest options-and-methods) + "Create a generic function NAME. +DOC-STRING is the base documentation for this class. A generic +function has no body, as its purpose is to decide which method body +is appropriate to use. Specific methods are defined with `cl-defmethod'. +With this implementation the ARGS are currently ignored. +OPTIONS-AND-METHODS currently understands: +- (:documentation DOCSTRING) +- (declare DECLARATIONS)" + (declare (indent 2) (doc-string 3)) + (let* ((docprop (assq :documentation options-and-methods)) + (doc (cond ((stringp (car-safe options-and-methods)) + (pop options-and-methods)) + (docprop + (prog1 + (cadr docprop) + (setq options-and-methods + (delq docprop options-and-methods)))))) + (declarations (assq 'declare options-and-methods))) + (when declarations + (setq options-and-methods + (delq declarations options-and-methods))) + `(progn + ,(when (eq 'setf (car-safe name)) + (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite + (cadr name)))) + (setq name setter) + code)) + ,@(mapcar (lambda (declaration) + (let ((f (cdr (assq (car declaration) + defun-declarations-alist)))) + (cond + (f (apply (car f) name args (cdr declaration))) + (t (message "Warning: Unknown defun property `%S' in %S" + (car declaration) name) + nil)))) + (cdr declarations)) + (defalias ',name + (cl-generic-define ',name ',args ',options-and-methods) + ,(help-add-fundoc-usage doc args))))) + +(defun cl--generic-mandatory-args (args) + (let ((res ())) + (while (not (memq (car args) '(nil &rest &optional &key))) + (push (pop args) res)) + (nreverse res))) + +;;;###autoload +(defun cl-generic-define (name args options-and-methods) + (let ((generic (cl-generic-ensure-function name)) + (mandatory (cl--generic-mandatory-args args)) + (apo (assq :argument-precedence-order options-and-methods))) + (setf (cl--generic-dispatches generic) nil) + (when apo + (dolist (arg (cdr apo)) + (let ((pos (memq arg mandatory))) + (unless pos (error "%S is not a mandatory argument" arg)) + (push (list (- (length mandatory) (length pos))) + (cl--generic-dispatches generic))))) + (setf (cl--generic-method-table generic) nil) + (cl--generic-make-function generic))) + +(defmacro cl-generic-current-method-specializers () + "List of (VAR . TYPE) where TYPE is var's specializer. +This macro can only be used within the lexical scope of a cl-generic method." + (error "cl-generic-current-method-specializers used outside of a method")) + +(eval-and-compile ;Needed while compiling the cl-defmethod calls below! + (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el. + "Check which of the symbols VARS appear in SEXP." + (let ((res '())) + (while (consp sexp) + (dolist (var (cl--generic-fgrep vars (pop sexp))) + (unless (memq var res) (push var res)))) + (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) + res)) + + (defun cl--generic-lambda (args body) + "Make the lambda expression for a method with ARGS and BODY." + (let ((plain-args ()) + (specializers nil) + (doc-string (if (and (stringp (car-safe body)) (cdr body)) + (pop body))) + (mandatory t)) + (dolist (arg args) + (push (pcase arg + ((or '&optional '&rest '&key) (setq mandatory nil) arg) + ((and `(,name . ,type) (guard mandatory)) + (push (cons name (car type)) specializers) + name) + (_ arg)) + plain-args)) + (setq plain-args (nreverse plain-args)) + (let ((fun `(cl-function (lambda ,plain-args + ,@(if doc-string (list doc-string)) + ,@body))) + (macroenv (cons `(cl-generic-current-method-specializers + . ,(lambda () specializers)) + macroexpand-all-environment))) + (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. + ;; First macroexpand away the cl-function stuff (e.g. &key and + ;; destructuring args, `declare' and whatnot). + (pcase (macroexpand fun macroenv) + (`#'(lambda ,args . ,body) + (let* ((doc-string (and doc-string (stringp (car body)) (cdr body) + (pop body))) + (cnm (make-symbol "cl--cnm")) + (nmp (make-symbol "cl--nmp")) + (nbody (macroexpand-all + `(cl-flet ((cl-call-next-method ,cnm) + (cl-next-method-p ,nmp)) + ,@body) + macroenv)) + ;; FIXME: Rather than `grep' after the fact, the + ;; macroexpansion should directly set some flag when cnm + ;; is used. + ;; FIXME: Also, optimize the case where call-next-method is + ;; only called with explicit arguments. + (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) + (cons (not (not uses-cnm)) + `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) + ,@(if doc-string (list doc-string)) + ,(if (not (memq nmp uses-cnm)) + nbody + `(let ((,nmp (lambda () + (cl--generic-isnot-nnm-p ,cnm)))) + ,nbody)))))) + (f (error "Unexpected macroexpansion result: %S" f))))))) + + +;;;###autoload +(defmacro cl-defmethod (name args &rest body) + "Define a new method for generic function NAME. +I.e. it defines the implementation of NAME to use for invocations where the +value of the dispatch argument matches the specified TYPE. +The dispatch argument has to be one of the mandatory arguments, and +all methods of NAME have to use the same argument for dispatch. +The dispatch argument and TYPE are specified in ARGS where the corresponding +formal argument appears as (VAR TYPE) rather than just VAR. + +The optional second argument QUALIFIER is a specifier that +modifies how the method is combined with other methods, including: + :before - Method will be called before the primary + :after - Method will be called after the primary + :around - Method will be called around everything else +The absence of QUALIFIER means this is a \"primary\" method. + +Other than a type, TYPE can also be of the form `(eql VAL)' in +which case this method will be invoked when the argument is `eql' to VAL. + +\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" + (declare (doc-string 3) (indent 2) + (debug + (&define ; this means we are defining something + [&or name ("setf" :name setf name)] + ;; ^^ This is the methods symbol + [ &optional keywordp ] ; this is key :before etc + list ; arguments + [ &optional stringp ] ; documentation string + def-body))) ; part to be debugged + (let ((qualifiers nil) + (setfizer (if (eq 'setf (car-safe name)) + ;; Call it before we call cl--generic-lambda. + (cl--generic-setf-rewrite (cadr name))))) + (while (not (listp args)) + (push args qualifiers) + (setq args (pop body))) + (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body))) + `(progn + ,(when setfizer + (setq name (car setfizer)) + (cdr setfizer)) + ,(and (get name 'byte-obsolete-info) + (or (not (fboundp 'byte-compile-warning-enabled-p)) + (byte-compile-warning-enabled-p 'obsolete)) + (let* ((obsolete (get name 'byte-obsolete-info))) + (macroexp--warn-and-return + (macroexp--obsolete-warning name obsolete "generic function") + nil))) + ;; You could argue that `defmethod' modifies rather than defines the + ;; function, so warnings like "not known to be defined" are fair game. + ;; But in practice, it's common to use `cl-defmethod' + ;; without a previous `cl-defgeneric'. + (declare-function ,name "") + (cl-generic-define-method ',name ',qualifiers ',args + ,uses-cnm ,fun))))) + +(defun cl--generic-member-method (specializers qualifiers methods) + (while + (and methods + (let ((m (car methods))) + (not (and (equal (cl--generic-method-specializers m) specializers) + (equal (cl--generic-method-qualifiers m) qualifiers))))) + (setq methods (cdr methods)) + methods)) + +;;;###autoload +(defun cl-generic-define-method (name qualifiers args uses-cnm function) + (let* ((generic (cl-generic-ensure-function name)) + (mandatory (cl--generic-mandatory-args args)) + (specializers + (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory)) + (method (cl--generic-method-make + specializers qualifiers uses-cnm function)) + (mt (cl--generic-method-table generic)) + (me (cl--generic-member-method specializers qualifiers mt)) + (dispatches (cl--generic-dispatches generic)) + (i 0)) + (dolist (specializer specializers) + (let* ((tagcode (funcall cl-generic-tagcode-function specializer 'arg)) + (x (assq i dispatches))) + (unless x + (setq x (list i (funcall cl-generic-tagcode-function t 'arg))) + (setf (cl--generic-dispatches generic) + (setq dispatches (cons x dispatches)))) + (unless (member tagcode (cdr x)) + (setf (cdr x) + (nreverse (sort (cons tagcode (cdr x)) + #'car-less-than-car)))) + (setq i (1+ i)))) + (if me (setcar me method) + (setf (cl--generic-method-table generic) (cons method mt))) + (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) + current-load-list :test #'equal) + (let ((gfun (cl--generic-make-function generic)) + ;; Prevent `defalias' from recording this as the definition site of + ;; the generic function. + current-load-list) + ;; For aliases, cl--generic-name gives us the actual name. + (defalias (cl--generic-name generic) gfun)))) + +(defmacro cl--generic-with-memoization (place &rest code) + (declare (indent 1) (debug t)) + (gv-letplace (getter setter) place + `(or ,getter + ,(macroexp-let2 nil val (macroexp-progn code) + `(progn + ,(funcall setter val) + ,val))))) + +(defvar cl--generic-dispatchers (make-hash-table :test #'equal)) + +(defun cl--generic-get-dispatcher (tagcodes dispatch-arg) + (cl--generic-with-memoization + (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers) + (let ((lexical-binding t) + (tag-exp `(or ,@(mapcar #'cdr + ;; Minor optimization: since this tag-exp is + ;; only used to lookup the method-cache, it + ;; doesn't matter if the default value is some + ;; constant or nil. + (if (macroexp-const-p (car (last tagcodes))) + (butlast tagcodes) + tagcodes)))) + (extraargs ())) + (dotimes (_ dispatch-arg) + (push (make-symbol "arg") extraargs)) + (byte-compile + `(lambda (generic dispatches-left) + (let ((method-cache (make-hash-table :test #'eql))) + (lambda (,@extraargs arg &rest args) + (apply (cl--generic-with-memoization + (gethash ,tag-exp method-cache) + (cl--generic-cache-miss + generic ',dispatch-arg dispatches-left + (list ,@(mapcar #'cdr tagcodes)))) + ,@extraargs arg args)))))))) + +(defun cl--generic-make-function (generic) + (let* ((dispatches (cl--generic-dispatches generic)) + (dispatch + (progn + (while (and dispatches + (member (cdar dispatches) + '(nil ((0 . 'cl--generic-type))))) + (setq dispatches (cdr dispatches))) + (pop dispatches)))) + (if (null dispatch) + (cl--generic-build-combined-method + (cl--generic-name generic) + (cl--generic-method-table generic)) + (let ((dispatcher (cl--generic-get-dispatcher + (cdr dispatch) (car dispatch)))) + (funcall dispatcher generic dispatches))))) + +(defvar cl-generic-method-combination-function + #'cl--generic-standard-method-combination + "Function to build the effective method. +Called with 2 arguments: NAME and METHOD-ALIST. +It should return an effective method, i.e. a function that expects the same +arguments as the methods, and calls those methods in some appropriate order. +NAME is the name (a symbol) of the corresponding generic function. +METHOD-ALIST is a list of elements (QUALIFIERS . METHODS) where +QUALIFIERS is a list of qualifiers, and METHODS is a list of the selected +methods for that qualifier list. +The METHODS lists are sorted from most generic first to most specific last. +The function can use `cl-generic-call-method' to create functions that call those +methods.") + +(defvar cl--generic-combined-method-memoization + (make-hash-table :test #'equal :weakness 'value) + "Table storing previously built combined-methods. +This is particularly useful when many different tags select the same set +of methods, since this table then allows us to share a single combined-method +for all those different tags in the method-cache.") + +(defun cl--generic-build-combined-method (generic-name methods) + (cl--generic-with-memoization + (gethash (cons generic-name methods) + cl--generic-combined-method-memoization) + (let ((mets-by-qual ())) + (dolist (method methods) + (let* ((qualifiers (cl--generic-method-qualifiers method)) + (x (assoc qualifiers mets-by-qual))) + ;; FIXME: sadly, alist-get only uses `assq' and we need `assoc'. + ;;(push (cdr qm) (alist-get qualifiers mets-by-qual))) + (if x + (push method (cdr x)) + (push (list qualifiers method) mets-by-qual)))) + (funcall cl-generic-method-combination-function + generic-name mets-by-qual)))) + +(defun cl--generic-no-next-method-function (generic method) + (lambda (&rest args) + (apply #'cl-no-next-method generic method args))) + +(defun cl-generic-call-method (generic-name method &optional fun) + "Return a function that calls METHOD. +FUN is the function that should be called when METHOD calls +`call-next-method'." + (if (not (cl--generic-method-uses-cnm method)) + (cl--generic-method-function method) + (let ((met-fun (cl--generic-method-function method)) + (next (or fun (cl--generic-no-next-method-function + generic-name method)))) + (lambda (&rest args) + (apply met-fun + ;; FIXME: This sucks: passing just `next' would + ;; be a lot more efficient than the lambda+apply + ;; quasi-η, but we need this to implement the + ;; "if call-next-method is called with no + ;; arguments, then use the previous arguments". + (lambda (&rest cnm-args) + (apply next (or cnm-args args))) + args))))) + +(defun cl--generic-standard-method-combination (generic-name mets-by-qual) + (dolist (x mets-by-qual) + (unless (member (car x) '(() (:after) (:before) (:around))) + (error "Unsupported qualifiers in function %S: %S" generic-name (car x)))) + (cond + ((null mets-by-qual) + (lambda (&rest args) + (apply #'cl-no-applicable-method generic-name args))) + ((null (alist-get nil mets-by-qual)) + (lambda (&rest args) + (apply #'cl-no-primary-method generic-name args))) + (t + (let* ((fun nil) + (ab-call (lambda (m) (cl-generic-call-method generic-name m))) + (before + (mapcar ab-call (reverse (cdr (assoc '(:before) mets-by-qual))))) + (after (mapcar ab-call (cdr (assoc '(:after) mets-by-qual))))) + (dolist (method (cdr (assoc nil mets-by-qual))) + (setq fun (cl-generic-call-method generic-name method fun))) + (when (or after before) + (let ((next fun)) + (setq fun (lambda (&rest args) + (dolist (bf before) + (apply bf args)) + (prog1 + (apply next args) + (dolist (af after) + (apply af args))))))) + (dolist (method (cdr (assoc '(:around) mets-by-qual))) + (setq fun (cl-generic-call-method generic-name method fun))) + fun)))) + +(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t)) +(defconst cl--generic-cnm-sample + (funcall (cl--generic-build-combined-method + nil (list (cl--generic-method-make () () t #'identity))))) + +(defun cl--generic-isnot-nnm-p (cnm) + "Return non-nil if CNM is the function that calls `cl-no-next-method'." + ;; ¡Big Gross Ugly Hack! + ;; `next-method-p' just sucks, we should let it die. But EIEIO did support + ;; it, and some packages use it, so we need to support it. + (catch 'found + (cl-assert (function-equal cnm cl--generic-cnm-sample)) + (if (byte-code-function-p cnm) + (let ((cnm-constants (aref cnm 2)) + (sample-constants (aref cl--generic-cnm-sample 2))) + (dotimes (i (length sample-constants)) + (when (function-equal (aref sample-constants i) + cl--generic-nnm-sample) + (throw 'found + (not (function-equal (aref cnm-constants i) + cl--generic-nnm-sample)))))) + (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample))) + (let ((cnm-env (cadr cnm))) + (dolist (vb (cadr cl--generic-cnm-sample)) + (when (function-equal (cdr vb) cl--generic-nnm-sample) + (throw 'found + (not (function-equal (cdar cnm-env) + cl--generic-nnm-sample)))) + (setq cnm-env (cdr cnm-env))))) + (error "Haven't found no-next-method-sample in cnm-sample"))) + +(defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags) + (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags))) + (methods '())) + (dolist (method (cl--generic-method-table generic)) + (let* ((specializer (or (nth dispatch-arg + (cl--generic-method-specializers method)) + t)) + (m (member specializer types))) + (when m + (push (cons (length m) method) methods)))) + ;; Sort the methods, most specific first. + ;; It would be tempting to sort them once and for all in the method-table + ;; rather than here, but the order might depend on the actual argument + ;; (e.g. for multiple inheritance with defclass). + (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car)))) + (cl--generic-make-function (cl--generic-make (cl--generic-name generic) + dispatches-left methods)))) + +;;; Define some pre-defined generic functions, used internally. + +(define-error 'cl-no-method "No method for %S") +(define-error 'cl-no-next-method "No next method for %S" 'cl-no-method) +(define-error 'cl-no-primary-method "No primary method for %S" 'cl-no-method) +(define-error 'cl-no-applicable-method "No applicable method for %S" + 'cl-no-method) + +(cl-defgeneric cl-no-next-method (generic method &rest args) + "Function called when `cl-call-next-method' finds no next method.") +(cl-defmethod cl-no-next-method (generic method &rest args) + (signal 'cl-no-next-method `(,generic ,method ,@args))) + +(cl-defgeneric cl-no-applicable-method (generic &rest args) + "Function called when a method call finds no applicable method.") +(cl-defmethod cl-no-applicable-method (generic &rest args) + (signal 'cl-no-applicable-method `(,generic ,@args))) + +(cl-defgeneric cl-no-primary-method (generic &rest args) + "Function called when a method call finds no primary method.") +(cl-defmethod cl-no-primary-method (generic &rest args) + (signal 'cl-no-primary-method `(,generic ,@args))) + +(defun cl-call-next-method (&rest _args) + "Function to call the next applicable method. +Can only be used from within the lexical body of a primary or around method." + (error "cl-call-next-method only allowed inside primary and around methods")) + +(defun cl-next-method-p () + "Return non-nil if there is a next method. +Can only be used from within the lexical body of a primary or around method." + (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1")) + (error "cl-next-method-p only allowed inside primary and around methods")) + +;;;###autoload +(defun cl-find-method (generic qualifiers specializers) + (car (cl--generic-member-method + specializers qualifiers + (cl--generic-method-table (cl--generic generic))))) + +(defalias 'cl-method-qualifiers 'cl--generic-method-qualifiers) + +;;; Add support for describe-function + +(defun cl--generic-search-method (met-name) + (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+" + (regexp-quote (format "%s\\_>" (car met-name)))))) + (or + (re-search-forward + (concat base-re "[^&\"\n]*" + (mapconcat (lambda (specializer) + (regexp-quote + (format "%S" (if (consp specializer) + (nth 1 specializer) specializer)))) + (remq t (cdr met-name)) + "[ \t\n]*)[^&\"\n]*")) + nil t) + (re-search-forward base-re nil t)))) + + +(with-eval-after-load 'find-func + (defvar find-function-regexp-alist) + (add-to-list 'find-function-regexp-alist + `(cl-defmethod . ,#'cl--generic-search-method))) + +(defun cl--generic-method-info (method) + (let* ((specializers (cl--generic-method-specializers method)) + (qualifiers (cl--generic-method-qualifiers method)) + (uses-cnm (cl--generic-method-uses-cnm method)) + (function (cl--generic-method-function method)) + (args (help-function-arglist function 'names)) + (docstring (documentation function)) + (qual-string + (if (null qualifiers) "" + (cl-assert (consp qualifiers)) + (let ((s (prin1-to-string qualifiers))) + (concat (substring s 1 -1) " ")))) + (doconly (if docstring + (let ((split (help-split-fundoc docstring nil))) + (if split (cdr split) docstring)))) + (combined-args ())) + (if uses-cnm (setq args (cdr args))) + (dolist (specializer specializers) + (let ((arg (if (eq '&rest (car args)) + (intern (format "arg%d" (length combined-args))) + (pop args)))) + (push (if (eq specializer t) arg (list arg specializer)) + combined-args))) + (setq combined-args (append (nreverse combined-args) args)) + (list qual-string combined-args doconly))) + +(add-hook 'help-fns-describe-function-functions #'cl--generic-describe) +(defun cl--generic-describe (function) + (let ((generic (if (symbolp function) (cl--generic function)))) + (when generic + (require 'help-mode) ;Needed for `help-function-def' button! + (save-excursion + (insert "\n\nThis is a generic function.\n\n") + (insert (propertize "Implementations:\n\n" 'face 'bold)) + ;; Loop over fanciful generics + (dolist (method (cl--generic-method-table generic)) + (let* ((info (cl--generic-method-info method))) + ;; FIXME: Add hyperlinks for the types as well. + (insert (format "%s%S" (nth 0 info) (nth 1 info))) + (let* ((met-name (cons function + (cl--generic-method-specializers method))) + (file (find-lisp-object-file-name met-name 'cl-defmethod))) + (when file + (insert " in `") + (help-insert-xref-button (help-fns-short-filename file) + 'help-function-def met-name file + 'cl-defmethod) + (insert "'.\n"))) + (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) + +;;; Support for (eql <val>) specializers. + +(defvar cl--generic-eql-used (make-hash-table :test #'eql)) + +(add-function :before-until cl-generic-tagcode-function + #'cl--generic-eql-tagcode) +(defun cl--generic-eql-tagcode (type name) + (when (eq (car-safe type) 'eql) + (puthash (cadr type) type cl--generic-eql-used) + `(100 . (gethash ,name cl--generic-eql-used)))) + +(add-function :before-until cl-generic-tag-types-function + #'cl--generic-eql-tag-types) +(defun cl--generic-eql-tag-types (tag) + (if (eq (car-safe tag) 'eql) (list tag))) + +;;; Support for cl-defstructs specializers. + +(add-function :before-until cl-generic-tagcode-function + #'cl--generic-struct-tagcode) +(defun cl--generic-struct-tagcode (type name) + (and (symbolp type) + (get type 'cl-struct-type) + (or (eq 'vector (car (get type 'cl-struct-type))) + (error "Can't dispatch on cl-struct %S: type is %S" + type (car (get type 'cl-struct-type)))) + (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots))) + (error "Can't dispatch on cl-struct %S: no tag in slot 0" + type)) + ;; We could/should check the vector has length >0, + ;; but really, mixing vectors and structs is a bad idea, + ;; so let's not waste time trying to handle the case + ;; of an empty vector. + ;; BEWARE: this returns a bogus tag for non-struct vectors. + `(50 . (and (vectorp ,name) (aref ,name 0))))) + +(add-function :before-until cl-generic-tag-types-function + #'cl--generic-struct-tag-types) +(defun cl--generic-struct-tag-types (tag) + ;; FIXME: cl-defstruct doesn't make it easy for us. + (and (symbolp tag) + ;; A method call shouldn't itself mess with the match-data. + (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag)) + (let ((types (list (intern (substring (symbol-name tag) 10))))) + (while (get (car types) 'cl-struct-include) + (push (get (car types) 'cl-struct-include) types)) + (push 'cl-struct types) ;The "parent type" of all cl-structs. + (nreverse types)))) + +;;; Dispatch on "system types". + +(defconst cl--generic-typeof-types + ;; Hand made from the source code of `type-of'. + '((integer number) (symbol) (string array sequence) (cons list sequence) + ;; Markers aren't `numberp', yet they are accepted wherever integers are + ;; accepted, pretty much. + (marker) (overlay) (float number) (window-configuration) + (process) (window) (subr) (compiled-function) (buffer) + (char-table array sequence) + (bool-vector array sequence) + (frame) (hash-table) (font-spec) (font-entity) (font-object) + (vector array sequence) + ;; Plus, hand made: + (null symbol list sequence) + (list sequence) + (array sequence) + (sequence) + (number))) + +(add-function :before-until cl-generic-tagcode-function + #'cl--generic-typeof-tagcode) +(defun cl--generic-typeof-tagcode (type name) + ;; FIXME: Add support for other types accepted by `cl-typep' such + ;; as `character', `atom', `face', `function', ... + (and (assq type cl--generic-typeof-types) + (progn + (if (memq type '(vector array sequence)) + (message "`%S' also matches CL structs and EIEIO classes" type)) + ;; FIXME: We could also change `type-of' to return `null' for nil. + `(10 . (if ,name (type-of ,name) 'null))))) + +(add-function :before-until cl-generic-tag-types-function + #'cl--generic-typeof-types) +(defun cl--generic-typeof-types (tag) + (and (symbolp tag) + (assq tag cl--generic-typeof-types))) + +;;; Just for kicks: dispatch on major-mode +;; +;; Here's how you'd use it: +;; (cl-defmethod foo ((x (major-mode text-mode)) y z) ...) +;; And then +;; (foo 'major-mode toto titi) +;; +;; FIXME: Better would be to do that via dispatch on an "implicit argument". +;; E.g. (cl-defmethod foo (y z &context (major-mode text-mode)) ...) + +;; (defvar cl--generic-major-modes (make-hash-table :test #'eq)) +;; +;; (add-function :before-until cl-generic-tagcode-function +;; #'cl--generic-major-mode-tagcode) +;; (defun cl--generic-major-mode-tagcode (type name) +;; (if (eq 'major-mode (car-safe type)) +;; `(50 . (if (eq ,name 'major-mode) +;; (cl--generic-with-memoization +;; (gethash major-mode cl--generic-major-modes) +;; `(cl--generic-major-mode . ,major-mode)))))) +;; +;; (add-function :before-until cl-generic-tag-types-function +;; #'cl--generic-major-mode-types) +;; (defun cl--generic-major-mode-types (tag) +;; (when (eq (car-safe tag) 'cl--generic-major-mode) +;; (if (eq tag 'fundamental-mode) '(fundamental-mode t) +;; (let ((types `((major-mode ,(cdr tag))))) +;; (while (get (car types) 'derived-mode-parent) +;; (push (list 'major-mode (get (car types) 'derived-mode-parent)) +;; types)) +;; (unless (eq 'fundamental-mode (car types)) +;; (push '(major-mode fundamental-mode) types)) +;; (nreverse types))))) + +;; Local variables: +;; generated-autoload-file: "cl-loaddefs.el" +;; End: + +(provide 'cl-generic) +;;; cl-generic.el ends here diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 5c49f843475..1bcfb6df2cf 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 eb5f2d4f98d..0f534181b22 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 34c040c1843..38f15b89b0e 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." @@ -619,14 +625,20 @@ The result of the body appears to the compiler as a quoted constant." (set `(setq ,temp ,form))) (if (and (fboundp 'byte-compile-file-form-defmumble) (boundp 'this-kind) (boundp 'that-one)) - (fset 'byte-compile-file-form - `(lambda (form) - (fset 'byte-compile-file-form - ',(symbol-function 'byte-compile-file-form)) - (byte-compile-file-form ',set) - (byte-compile-file-form form))) - (print set (symbol-value 'byte-compile--outbuffer))) - `(symbol-value ',temp)) + ;; Else, we can't output right away, so we have to delay it to the + ;; next time we're at the top-level. + ;; FIXME: Use advice-add/remove. + (fset 'byte-compile-file-form + (let ((old (symbol-function 'byte-compile-file-form))) + (lambda (form) + (fset 'byte-compile-file-form old) + (byte-compile-file-form set) + (byte-compile-file-form form)))) + ;; If we're not in the middle of compiling something, we can + ;; output directly to byte-compile-outbuffer, to make sure + ;; temp is set before we use it. + (print set byte-compile--outbuffer)) + temp) `',(eval form))) @@ -816,7 +828,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 +1143,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 +1202,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 +1379,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 +1398,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 +1414,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 +1447,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 +1519,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 +1561,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. @@ -1786,6 +1807,8 @@ a `let' form, except that the list of symbols can be computed at run-time." (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) (eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun)))))))) +(defconst cl--labels-magic (make-symbol "cl--labels-magic")) + (defvar cl--labels-convert-cache nil) (defun cl--labels-convert (f) @@ -1797,10 +1820,12 @@ a `let' form, except that the list of symbols can be computed at run-time." ;; being expanded even though we don't receive it. ((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache)) (t - (let ((found (assq f macroexpand-all-environment))) - (if (and found (ignore-errors - (eq (cadr (cl-caddr found)) 'cl-labels-args))) - (cadr (cl-caddr (cl-cadddr found))) + (let* ((found (assq f macroexpand-all-environment)) + (replacement (and found + (ignore-errors + (funcall (cdr found) cl--labels-magic))))) + (if (and replacement (eq cl--labels-magic (car replacement))) + (nth 1 replacement) (let ((res `(function ,f))) (setq cl--labels-convert-cache (cons f res)) res)))))) @@ -1809,25 +1834,38 @@ a `let' form, except that the list of symbols can be computed at run-time." (defmacro cl-flet (bindings &rest body) "Make local function definitions. Like `cl-labels' but the definitions are not recursive. +Each binding can take the form (FUNC EXP) where +FUNC is the function name, and EXP is an expression that returns the +function value to which it should be bound, or it can take the more common +form \(FUNC ARGLIST BODY...) which is a shorthand +for (FUNC (lambda ARGLIST BODY)). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) - (let ((var (make-symbol (format "--cl-%s--" (car binding))))) - (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (let ((var (make-symbol (format "--cl-%s--" (car binding)))) + (args-and-body (cdr binding))) + (if (and (= (length args-and-body) 1) (symbolp (car args-and-body))) + ;; Optimize (cl-flet ((fun var)) body). + (setq var (car args-and-body)) + (push (list var (if (= (length args-and-body) 1) + (car args-and-body) + `(cl-function (lambda . ,args-and-body)))) + binds)) (push (cons (car binding) - `(lambda (&rest cl-labels-args) - (cl-list* 'funcall ',var - cl-labels-args))) + (lambda (&rest args) + (if (eq (car args) cl--labels-magic) + (list cl--labels-magic var) + `(funcall ,var ,@args)))) newenv))) - `(let ,(nreverse binds) - ,@(macroexp-unprogn - (macroexpand-all - `(progn ,@body) - ;; Don't override lexical-let's macro-expander. - (if (assq 'function newenv) newenv - (cons (cons 'function #'cl--labels-convert) newenv))))))) + ;; FIXME: Eliminate those functions which aren't referenced. + (macroexp-let* (nreverse binds) + (macroexpand-all + `(progn ,@body) + ;; Don't override lexical-let's macro-expander. + (if (assq 'function newenv) newenv + (cons (cons 'function #'cl--labels-convert) newenv)))))) ;;;###autoload (defmacro cl-flet* (bindings &rest body) @@ -1854,9 +1892,10 @@ in closures will only work if `lexical-binding' is in use. (let ((var (make-symbol (format "--cl-%s--" (car binding))))) (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) (push (cons (car binding) - `(lambda (&rest cl-labels-args) - (cl-list* 'funcall ',var - cl-labels-args))) + (lambda (&rest args) + (if (eq (car args) cl--labels-magic) + (list cl--labels-magic var) + (cl-list* 'funcall var args)))) newenv))) (macroexpand-all `(letrec ,(nreverse binds) ,@body) ;; Don't override lexical-let's macro-expander. @@ -1878,13 +1917,14 @@ This is like `cl-flet', but for macros instead of functions. cl-declarations body))) (if (cdr bindings) `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) - (if (null bindings) (cons 'progn body) + (if (null bindings) (macroexp-progn body) (let* ((name (caar bindings)) (res (cl--transform-lambda (cdar bindings) name))) (eval (car res)) - (macroexpand-all (cons 'progn body) - (cons (cons name `(lambda ,@(cdr res))) - macroexpand-all-environment)))))) + (macroexpand-all (macroexp-progn body) + (cons (cons name + (eval `(cl-function (lambda ,@(cdr res))) t)) + macroexpand-all-environment)))))) (defconst cl--old-macroexpand (if (and (boundp 'cl--old-macroexpand) @@ -2057,10 +2097,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 +2432,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 +2512,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 +2529,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 +2552,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 +2585,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 +2608,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 +2631,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 +2676,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 +2792,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 +2931,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 +2955,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 2c872f26146..5624accf66a 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/cl.el b/lisp/emacs-lisp/cl.el index da3eab73fc4..1b204631fb8 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -342,6 +342,8 @@ The two cases that are handled are: - renaming of F when it's a function defined via `cl-labels' or `labels'." (require 'cl-macs) (declare-function cl--expr-contains-any "cl-macs" (x y)) + (declare-function cl--labels-convert "cl-macs" (f)) + (defvar cl--labels-convert-cache) (cond ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked ;; *after* handling `function', but we want to stop macroexpansion from @@ -374,13 +376,10 @@ The two cases that are handled are: (setq cl--function-convert-cache (cons newf res)) res)))) (t - (let ((found (assq f macroexpand-all-environment))) - (if (and found (ignore-errors - (eq (cadr (cl-caddr found)) 'cl-labels-args))) - (cadr (cl-caddr (cl-cadddr found))) - (let ((res `(function ,f))) - (setq cl--function-convert-cache (cons f res)) - res)))))) + (setq cl--labels-convert-cache cl--function-convert-cache) + (prog1 + (cl--labels-convert f) + (setq cl--function-convert-cache cl--labels-convert-cache))))) (defmacro lexical-let (bindings &rest body) "Like `let', but lexically scoped. diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index a250ea60d21..52da4c99eaf 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -162,7 +162,8 @@ The new mode runs the hook constructed by the function See Info node `(elisp)Derived Modes' for more details." (declare (debug (&define name symbolp sexp [&optional stringp] [&rest keywordp sexp] def-body)) - (doc-string 4)) + (doc-string 4) + (indent 3)) (when (and docstring (not (stringp docstring))) ;; Some trickiness, since what appears to be the docstring may really be diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index f58bb076406..7e6f56518a2 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 f8defb1171b..7faa101299e 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -411,12 +411,7 @@ Return the result of the last expression in BODY." ;; read is redefined to maybe instrument forms. ;; eval-defun is redefined to check edebug-all-forms and edebug-all-defs. -;; Save the original read function -(defalias 'edebug-original-read - (symbol-function (if (fboundp 'edebug-original-read) - 'edebug-original-read 'read))) - -(defun edebug-read (&optional stream) +(defun edebug--read (orig &optional stream) "Read one Lisp expression as text from STREAM, return as Lisp object. If STREAM is nil, use the value of `standard-input' (which see). STREAM or the value of `standard-input' may be: @@ -434,10 +429,7 @@ the option `edebug-all-forms'." (or stream (setq stream standard-input)) (if (eq stream (current-buffer)) (edebug-read-and-maybe-wrap-form) - (edebug-original-read stream))) - -(or (fboundp 'edebug-original-eval-defun) - (defalias 'edebug-original-eval-defun (symbol-function 'eval-defun))) + (funcall (or orig #'read) stream))) (defvar edebug-result) ; The result of the function call returned by body. @@ -568,16 +560,13 @@ already is one.)" (defun edebug-install-read-eval-functions () (interactive) - ;; Don't install if already installed. - (unless load-read-function - (setq load-read-function 'edebug-read) - (defalias 'eval-defun 'edebug-eval-defun))) + (add-function :around load-read-function #'edebug--read) + (advice-add 'eval-defun :override 'edebug-eval-defun)) (defun edebug-uninstall-read-eval-functions () (interactive) - (setq load-read-function nil) - (defalias 'eval-defun (symbol-function 'edebug-original-eval-defun))) - + (remove-function load-read-function #'edebug--read) + (advice-remove 'eval-defun 'edebug-eval-defun)) ;;; Edebug internal data @@ -722,8 +711,8 @@ Maybe clear the markers and delete the symbol's edebug property?" (cond ;; read goes one too far if a (possibly quoted) string or symbol ;; is immediately followed by non-whitespace. - ((eq class 'symbol) (edebug-original-read (current-buffer))) - ((eq class 'string) (edebug-original-read (current-buffer))) + ((eq class 'symbol) (read (current-buffer))) + ((eq class 'string) (read (current-buffer))) ((eq class 'quote) (forward-char 1) (list 'quote (edebug-read-sexp))) ((eq class 'backquote) @@ -731,7 +720,7 @@ Maybe clear the markers and delete the symbol's edebug property?" ((eq class 'comma) (list '\, (edebug-read-sexp))) (t ; anything else, just read it. - (edebug-original-read (current-buffer)))))) + (read (current-buffer)))))) ;;; Offsets for reader @@ -827,14 +816,11 @@ Maybe clear the markers and delete the symbol's edebug property?" (funcall (or (cdr (assq (edebug-next-token-class) edebug-read-alist)) ;; anything else, just read it. - 'edebug-original-read) + #'read) stream)))) -(defun edebug-read-symbol (stream) - (edebug-original-read stream)) - -(defun edebug-read-string (stream) - (edebug-original-read stream)) +(defalias 'edebug-read-symbol #'read) +(defalias 'edebug-read-string #'read) (defun edebug-read-quote (stream) ;; Turn 'thing into (quote thing) @@ -878,7 +864,7 @@ Maybe clear the markers and delete the symbol's edebug property?" ((memq (following-char) '(?: ?B ?O ?X ?b ?o ?x ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?0)) (backward-char 1) - (edebug-original-read stream)) + (read stream)) (t (edebug-syntax-error "Bad char after #")))) (defun edebug-read-list (stream) @@ -1049,16 +1035,15 @@ Maybe clear the markers and delete the symbol's edebug property?" edebug-gate edebug-best-error edebug-error-point - no-match ;; Do this once here instead of several times. (max-lisp-eval-depth (+ 800 max-lisp-eval-depth)) (max-specpdl-size (+ 2000 max-specpdl-size))) - (setq no-match - (catch 'no-match - (setq result (edebug-read-and-maybe-wrap-form1)) - nil)) - (if no-match - (apply 'edebug-syntax-error no-match)) + (let ((no-match + (catch 'no-match + (setq result (edebug-read-and-maybe-wrap-form1)) + nil))) + (if no-match + (apply 'edebug-syntax-error no-match))) result)) @@ -1077,7 +1062,7 @@ Maybe clear the markers and delete the symbol's edebug property?" (if (and (eq 'lparen (edebug-next-token-class)) (eq 'symbol (progn (forward-char 1) (edebug-next-token-class)))) ;; Find out if this is a defining form from first symbol - (setq def-kind (edebug-original-read (current-buffer)) + (setq def-kind (read (current-buffer)) spec (and (symbolp def-kind) (get-edebug-spec def-kind)) defining-form-p (and (listp spec) (eq '&define (car spec))) @@ -1085,7 +1070,7 @@ Maybe clear the markers and delete the symbol's edebug property?" def-name (if (and defining-form-p (eq 'name (car (cdr spec))) (eq 'symbol (edebug-next-token-class))) - (edebug-original-read (current-buffer)))))) + (read (current-buffer)))))) ;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) (cond (defining-form-p @@ -3210,7 +3195,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)))) @@ -3238,25 +3223,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)))) @@ -3400,9 +3374,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 @@ -4137,9 +4109,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 4cbec768d8b..feb06711cb3 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-2015 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 ;; @@ -40,7 +40,7 @@ ;; error if a slot is unbound. (defclass eieio-instance-inheritor () ((parent-instance :initarg :parent-instance - :type eieio-instance-inheritor-child + :type eieio-instance-inheritor :documentation "The parent of this instance. If a slot of this class is referenced, and is unbound, then the parent @@ -52,7 +52,8 @@ a parent instance. When a slot in the child is referenced, and has not been set, use values from the parent." :abstract t) -(defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn) +(cl-defmethod slot-unbound ((object eieio-instance-inheritor) + _class slot-name _fn) "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal. SLOT-NAME is the offending slot. FN is the function signaling the error." (if (slot-boundp object 'parent-instance) @@ -60,31 +61,16 @@ SLOT-NAME is the offending slot. FN is the function signaling the error." ;; method if the parent instance's slot is unbound. (eieio-oref (oref object parent-instance) slot-name) ;; Throw the regular signal. - (call-next-method))) + (cl-call-next-method))) -(defmethod clone ((obj eieio-instance-inheritor) &rest params) +(cl-defmethod clone ((obj eieio-instance-inheritor) &rest _params) "Clone OBJ, initializing `:parent' to OBJ. All slots are unbound, except those initialized with PARAMS." - (let ((nobj (make-vector (length obj) eieio-unbound)) - (nm (eieio--object-name obj)) - (passname (and params (stringp (car params)))) - (num 1)) - (aset nobj 0 'object) - (setf (eieio--object-class nobj) (eieio--object-class obj)) - ;; The following was copied from the default clone. - (if (not passname) - (save-match-data - (if (string-match "-\\([0-9]+\\)" nm) - (setq num (1+ (string-to-number (match-string 1 nm))) - nm (substring nm 0 (match-beginning 0)))) - (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num)))) - (setf (eieio--object-name nobj) (car params))) - ;; Now initialize from params. - (if params (shared-initialize nobj (if passname (cdr params) params))) + (let ((nobj (cl-call-next-method))) (oset nobj parent-instance obj) nobj)) -(defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor) +(cl-defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor) slot) "Return non-nil if the instance inheritor OBJECT's SLOT is bound. See `slot-boundp' for details on binding slots. @@ -117,8 +103,8 @@ Inheritors from this class must overload `tracking-symbol' which is a variable symbol used to store a list of all instances." :abstract t) -(defmethod initialize-instance :AFTER ((this eieio-instance-tracker) - &rest slots) +(cl-defmethod initialize-instance :after ((this eieio-instance-tracker) + &rest _slots) "Make sure THIS is in our master list of this class. Optional argument SLOTS are the initialization arguments." ;; Theoretically, this is never called twice for a given instance. @@ -126,7 +112,7 @@ Optional argument SLOTS are the initialization arguments." (if (not (memq this (symbol-value sym))) (set sym (append (symbol-value sym) (list this)))))) -(defmethod delete-instance ((this eieio-instance-tracker)) +(cl-defmethod delete-instance ((this eieio-instance-tracker)) "Remove THIS from the master list of this class." (set (oref this tracking-symbol) (delq this (symbol-value (oref this tracking-symbol))))) @@ -154,7 +140,7 @@ Multiple calls to `make-instance' will return this object.")) A singleton is a class which will only ever have one instance." :abstract t) -(defmethod constructor :STATIC ((class eieio-singleton) name &rest slots) +(cl-defmethod eieio-constructor ((class (subclass eieio-singleton)) &rest _slots) "Constructor for singleton CLASS. NAME and SLOTS initialize the new object. This constructor guarantees that no matter how many you request, @@ -163,7 +149,7 @@ only one object ever exists." ;; with class allocated slots or default values. (let ((old (oref-default class singleton))) (if (eq old eieio-unbound) - (oset-default class singleton (call-next-method)) + (oset-default class singleton (cl-call-next-method)) old))) @@ -212,7 +198,7 @@ object. For this reason, only slots which do not have an `:initarg' specified will not be saved." :abstract t) -(defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt +(cl-defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt &optional name) "Prepare to save THIS. Use in an `interactive' statement. Query user for file name with PROMPT if THIS does not yet specify @@ -269,7 +255,7 @@ malicious code. Note: This function recurses when a slot of :type of some object is identified, and needing more object creation." (let ((objclass (nth 0 inputlist)) - (objname (nth 1 inputlist)) + ;; (objname (nth 1 inputlist)) (slots (nthcdr 2 inputlist)) (createslots nil)) @@ -284,7 +270,7 @@ identified, and needing more object creation." ;; In addition, strip out quotes, list functions, and update ;; object constructors as needed. (setq value (eieio-persistent-validate/fix-slot-value - objclass name value)) + (eieio--class-v objclass) name value)) (push name createslots) (push value createslots) @@ -292,7 +278,7 @@ identified, and needing more object creation." (setq slots (cdr (cdr slots)))) - (apply 'make-instance objclass objname (nreverse createslots)) + (apply #'make-instance objclass (nreverse createslots)) ;;(eval inputlist) )) @@ -304,11 +290,13 @@ constructor functions are considered valid. Second, any text properties will be stripped from strings." (cond ((consp proposed-value) ;; Lists with something in them need special treatment. - (let ((slot-idx (eieio-slot-name-index class nil slot)) + (let ((slot-idx (eieio--slot-name-index class + nil slot)) (type nil) (classtype nil)) - (setq slot-idx (- slot-idx 3)) - (setq type (aref (eieio--class-public-type (class-v class)) + (setq slot-idx (- slot-idx + (eval-when-compile eieio--object-num-slots))) + (setq type (aref (eieio--class-public-type class) slot-idx)) (setq classtype (eieio-persistent-slot-type-is-class-p @@ -345,8 +333,8 @@ Second, any text properties will be stripped from strings." (unless (and ;; Do we have a type? (consp classtype) (class-p (car classtype))) - (error "In save file, list of object constructors found, but no :type specified for slot %S" - slot)) + (error "In save file, list of object constructors found, but no :type specified for slot %S of type %S" + slot classtype)) ;; We have a predicate, but it doesn't satisfy the predicate? (dolist (PV (cdr proposed-value)) @@ -374,31 +362,49 @@ Second, any text properties will be stripped from strings." ) (defun eieio-persistent-slot-type-is-class-p (type) - "Return the class refered to in TYPE. + "Return the class referred to in TYPE. If no class is referenced there, then return nil." (cond ((class-p type) ;; If the type is a class, then return it. type) - - ((and (symbolp type) (string-match "-child$" (symbol-name type)) + ((and (eq 'list-of (car-safe type)) (class-p (cadr type))) + ;; If it is the type of a list of a class, then return that class and + ;; the type. + (cons (cadr type) type)) + + ((and (symbolp type) (get type 'cl-deftype-handler)) + ;; Macro-expand the type according to cl-deftype definitions. + (eieio-persistent-slot-type-is-class-p + (funcall (get type 'cl-deftype-handler)))) + + ;; FIXME: foo-child should not be a valid type! + ((and (symbolp type) (string-match "-child\\'" (symbol-name type)) (class-p (intern-soft (substring (symbol-name type) 0 (match-beginning 0))))) + (unless eieio-backward-compatibility + (error "Use of bogus %S type instead of %S" + type (intern-soft (substring (symbol-name type) 0 + (match-beginning 0))))) ;; If it is the predicate ending with -child, then return ;; that class. Unfortunately, in EIEIO, typep of just the ;; class is the same as if we used -child, so no further work needed. (intern-soft (substring (symbol-name type) 0 (match-beginning 0)))) - - ((and (symbolp type) (string-match "-list$" (symbol-name type)) + ;; FIXME: foo-list should not be a valid type! + ((and (symbolp type) (string-match "-list\\'" (symbol-name type)) (class-p (intern-soft (substring (symbol-name type) 0 (match-beginning 0))))) + (unless eieio-backward-compatibility + (error "Use of bogus %S type instead of (list-of %S)" + type (intern-soft (substring (symbol-name type) 0 + (match-beginning 0))))) ;; If it is the predicate ending with -list, then return ;; that class and the predicate to use. (cons (intern-soft (substring (symbol-name type) 0 (match-beginning 0))) type)) - ((and (consp type) (eq (car type) 'or)) + ((eq (car-safe type) 'or) ;; If type is a list, and is an or, it is possibly something ;; like (or null myclass), so check for that. (let ((ans nil)) @@ -411,17 +417,17 @@ If no class is referenced there, then return nil." ;; No match, not a class. nil))) -(defmethod object-write ((this eieio-persistent) &optional comment) +(cl-defmethod object-write ((this eieio-persistent) &optional comment) "Write persistent object THIS out to the current stream. Optional argument COMMENT is a header line comment." - (call-next-method this (or comment (oref this file-header-line)))) + (cl-call-next-method this (or comment (oref this file-header-line)))) -(defmethod eieio-persistent-path-relative ((this eieio-persistent) file) +(cl-defmethod eieio-persistent-path-relative ((this eieio-persistent) file) "For object THIS, make absolute file name FILE relative." (file-relative-name (expand-file-name file) (file-name-directory (oref this file)))) -(defmethod eieio-persistent-save ((this eieio-persistent) &optional file) +(cl-defmethod eieio-persistent-save ((this eieio-persistent) &optional file) "Save persistent object THIS to disk. Optional argument FILE overrides the file name specified in the object instance." @@ -462,34 +468,38 @@ instance." ;;; Named object -;; -;; Named objects use the objects `name' as a slot, and that slot -;; is accessed with the `object-name' symbol. (defclass eieio-named () - () - "Object with a name. -Name storage already occurs in an object. This object provides get/set -access to it." + ((object-name :initarg :object-name :initform nil)) + "Object with a name." :abstract t) -(defmethod slot-missing ((obj eieio-named) - slot-name operation &optional new-value) - "Called when a non-existent slot is accessed. -For variable `eieio-named', provide an imaginary `object-name' slot. -Argument OBJ is the named object. -Argument SLOT-NAME is the slot that was attempted to be accessed. -OPERATION is the type of access, such as `oref' or `oset'. -NEW-VALUE is the value that was being set into SLOT if OPERATION were -a set type." - (if (memq slot-name '(object-name :object-name)) - (cond ((eq operation 'oset) - (if (not (stringp new-value)) - (signal 'invalid-slot-type - (list obj slot-name 'string new-value))) - (eieio-object-set-name-string obj new-value)) - (t (eieio-object-name-string obj))) - (call-next-method))) +(cl-defmethod eieio-object-name-string ((obj eieio-named)) + "Return a string which is OBJ's name." + (or (slot-value obj 'object-name) + (symbol-name (eieio-object-class obj)))) + +(cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) + "Set the string which is OBJ's NAME." + (eieio--check-type stringp name) + (eieio-oset obj 'object-name name)) + +(cl-defmethod clone ((obj eieio-named) &rest params) + "Clone OBJ, initializing `:parent' to OBJ. +All slots are unbound, except those initialized with PARAMS." + (let* ((newname (and (stringp (car params)) (pop params))) + (nobj (apply #'cl-call-next-method obj params)) + (nm (slot-value obj 'object-name))) + (eieio-oset obj 'object-name + (or newname + (save-match-data + (if (and nm (string-match "-\\([0-9]+\\)" nm)) + (let ((num (1+ (string-to-number + (match-string 1 nm))))) + (concat (substring nm 0 (match-beginning 0)) + "-" (int-to-string num))) + (concat nm "-1"))))) + nobj)) (provide 'eieio-base) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el new file mode 100644 index 00000000000..fcca99d79d5 --- /dev/null +++ b/lisp/emacs-lisp/eieio-compat.el @@ -0,0 +1,264 @@ +;;; eieio-compat.el --- Compatibility with Older EIEIO versions -*- lexical-binding:t -*- + +;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: OO, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Backward compatibility definition of old EIEIO functions in +;; terms of newer equivalent. + +;; The main elements are the old EIEIO `defmethod' and `defgeneric' which are +;; now implemented on top of cl-generic. The differences we have to +;; accommodate are: +;; - EIEIO's :static methods (turned into a new `eieio--static' specializer). +;; - EIEIO's support for `call-next-method' and `next-method-p' instead of +;; `cl-next-method-p' and `cl-call-next-method' (simple matter of renaming). +;; - Different errors are signaled. +;; - EIEIO's defgeneric does not reset the function. +;; - EIEIO's no-next-method and no-applicable-method can't be aliases of +;; cl-generic's namesakes since they have different calling conventions, +;; which means that packages that (defmethod no-next-method ..) don't work. +;; - EIEIO's `call-next-method' and `next-method-p' had dynamic scope whereas +;; cl-generic's `cl-next-method-p' and `cl-call-next-method' are lexically +;; scoped. + +;;; Code: + +(require 'eieio-core) +(require 'cl-generic) + +(put 'eieio--defalias 'byte-hunk-handler + #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) +;;;###autoload +(defun eieio--defalias (name body) + "Like `defalias', but with less side-effects. +More specifically, it has no side-effects at all when the new function +definition is the same (`eq') as the old one." + (cl-assert (not (symbolp body))) + (while (and (fboundp name) (symbolp (symbol-function name))) + ;; Follow aliases, so methods applied to obsolete aliases still work. + (setq name (symbol-function name))) + (unless (and (fboundp name) + (eq (symbol-function name) body)) + (defalias name body))) + +;;;###autoload +(defmacro defgeneric (method args &optional doc-string) + "Create a generic function METHOD. +DOC-STRING is the base documentation for this class. A generic +function has no body, as its purpose is to decide which method body +is appropriate to use. Uses `defmethod' to create methods, and calls +`defgeneric' for you. With this implementation the ARGS are +currently ignored. You can use `defgeneric' to apply specialized +top level documentation to a method." + (declare (doc-string 3) (obsolete cl-defgeneric "25.1")) + `(eieio--defalias ',method + (eieio--defgeneric-init-form + ',method + ,(if doc-string (help-add-fundoc-usage doc-string args))))) + +;;;###autoload +(defmacro defmethod (method &rest args) + "Create a new METHOD through `defgeneric' with ARGS. + +The optional second argument KEY is a specifier that +modifies how the method is called, including: + :before - Method will be called before the :primary + :primary - The default if not specified + :after - Method will be called after the :primary + :static - First arg could be an object or class +The next argument is the ARGLIST. The ARGLIST specifies the arguments +to the method as with `defun'. The first argument can have a type +specifier, such as: + ((VARNAME CLASS) ARG2 ...) +where VARNAME is the name of the local variable for the method being +created. The CLASS is a class symbol for a class made with `defclass'. +A DOCSTRING comes after the ARGLIST, and is optional. +All the rest of the args are the BODY of the method. A method will +return the value of the last form in the BODY. + +Summary: + + (defmethod mymethod [:before | :primary | :after | :static] + ((typearg class-name) arg2 &optional opt &rest rest) + \"doc-string\" + body)" + (declare (doc-string 3) (obsolete cl-defmethod "25.1") + (debug + (&define ; this means we are defining something + [&or name ("setf" :name setf name)] + ;; ^^ This is the methods symbol + [ &optional symbolp ] ; this is key :before etc + list ; arguments + [ &optional stringp ] ; documentation string + def-body ; part to be debugged + ))) + (let* ((key (if (keywordp (car args)) (pop args))) + (params (car args)) + (arg1 (car params)) + (fargs (if (consp arg1) + (cons (car arg1) (cdr params)) + params)) + (class (if (consp arg1) (nth 1 arg1))) + (code `(lambda ,fargs ,@(cdr args)))) + `(progn + ;; Make sure there is a generic and the byte-compiler sees it. + (defgeneric ,method ,args) + (eieio--defmethod ',method ',key ',class #',code)))) + +(add-function :before-until cl-generic-tagcode-function + #'eieio--generic-static-tagcode) +(defun eieio--generic-static-tagcode (type name) + (and (eq 'eieio--static (car-safe type)) + `(40 . (cond + ((symbolp ,name) (eieio--class-v ,name)) + ((vectorp ,name) (aref ,name 0)))))) + +(add-function :around cl-generic-tag-types-function + #'eieio--generic-static-tag-types) +(defun eieio--generic-static-tag-types (orig-fun tag) + (cond + ((or (eieio--class-p tag) + (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)))) + (let ((superclasses (funcall orig-fun tag)) + (types ())) + ;; Interleave: (subclass <foo>) (eieio--static <foo>) <subclass <bar>) .. + (dolist (superclass superclasses) + (push superclass types) + (push `(eieio--static + ,(if (consp superclass) (cadr superclass) superclass)) + types)) + (nreverse types))) + (t (funcall orig-fun tag)))) + +;;;###autoload +(defun eieio--defgeneric-init-form (method doc-string) + (if doc-string (put method 'function-documentation doc-string)) + (if (memq method '(no-next-method no-applicable-method)) + (symbol-function method) + (let ((generic (cl-generic-ensure-function method))) + (symbol-function (cl--generic-name generic))))) + +;;;###autoload +(defun eieio--defmethod (method kind argclass code) + (setq kind (intern (downcase (symbol-name kind)))) + (let* ((specializer (if (not (eq kind :static)) + (or argclass t) + (setq kind nil) + `(eieio--static ,argclass))) + (uses-cnm (not (memq kind '(:before :after)))) + (specializers `((arg ,specializer))) + (code + ;; Backward compatibility for `no-next-method' and + ;; `no-applicable-method', which have slightly different calling + ;; convention than their cl-generic counterpart. + (pcase method + (`no-next-method + (setq method 'cl-no-next-method) + (setq specializers `(generic method ,@specializers)) + (lambda (_generic _method &rest args) (apply code args))) + (`no-applicable-method + (setq method 'cl-no-applicable-method) + (setq specializers `(generic ,@specializers)) + (lambda (generic arg &rest args) (apply code arg generic args))) + (_ code)))) + (cl-generic-define-method + method (unless (memq kind '(nil :primary)) (list kind)) + specializers uses-cnm + (if uses-cnm + (let* ((docstring (documentation code 'raw)) + (args (help-function-arglist code 'preserve-names)) + (doc-only (if docstring + (let ((split (help-split-fundoc docstring nil))) + (if split (cdr split) docstring)))) + (new-docstring (help-add-fundoc-usage doc-only + (cons 'cl-cnm args)))) + ;; FIXME: ¡Add new-docstring to those closures! + (lambda (cnm &rest args) + (cl-letf (((symbol-function 'call-next-method) cnm) + ((symbol-function 'next-method-p) + (lambda () (cl--generic-isnot-nnm-p cnm)))) + (apply code args)))) + code)) + ;; The old EIEIO code did not signal an error when there are methods + ;; applicable but only of the before/after kind. So if we add a :before + ;; or :after, make sure there's a matching dummy primary. + (when (and (memq kind '(:before :after)) + ;; FIXME: Use `cl-find-method'? + (not (cl-find-method method () + (mapcar (lambda (arg) + (if (consp arg) (nth 1 arg) t)) + specializers)))) + (cl-generic-define-method method () specializers t + (lambda (cnm &rest args) + (if (cl--generic-isnot-nnm-p cnm) + (apply cnm args))))) + method)) + +;; Compatibility with code which tries to catch `no-method-definition' errors. +(push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions)) + +(defun generic-p (fname) (not (null (cl--generic fname)))) + +(defun no-next-method (&rest args) + (declare (obsolete cl-no-next-method "25.1")) + (apply #'cl-no-next-method 'unknown nil args)) + +(defun no-applicable-method (object method &rest args) + (declare (obsolete cl-no-applicable-method "25.1")) + (apply #'cl-no-applicable-method method object args)) + +(define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1") +(defun next-method-p () + (declare (obsolete cl-next-method-p "25.1")) + ;; EIEIO's `next-method-p' just returned nil when called in an + ;; invalid context. + (message "next-method-p called outside of a primary or around method") + nil) + +;;;###autoload +(defun eieio-defmethod (method args) + "Obsolete work part of an old version of the `defmethod' macro." + (declare (obsolete cl-defmethod "24.1")) + (eval `(defmethod ,method ,@args)) + method) + +;;;###autoload +(defun eieio-defgeneric (method doc-string) + "Obsolete work part of an old version of the `defgeneric' macro." + (declare (obsolete cl-defgeneric "24.1")) + (eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string)))) + ;; Return the method + 'method) + +;;;###autoload +(defun eieio-defclass (cname superclasses slots options) + (declare (obsolete eieio-defclass-internal "25.1")) + (eval `(defclass ,cname ,superclasses ,slots ,@options))) + + +;; Local Variables: +;; generated-autoload-file: "eieio-core.el" +;; End: + +(provide 'eieio-compat) + +;;; eieio-compat.el ends here diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index cf430d32dd9..7492f0522ab 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-2015 Free Software Foundation, Inc. @@ -31,31 +31,8 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! - -;; Compatibility -(if (fboundp 'compiled-function-arglist) - - ;; XEmacs can only access a compiled functions arglist like this: - (defalias 'eieio-compiled-function-arglist 'compiled-function-arglist) - - ;; Emacs doesn't have this function, but since FUNC is a vector, we can just - ;; grab the appropriate element. - (defun eieio-compiled-function-arglist (func) - "Return the argument list for the compiled function FUNC." - (aref func 0)) - - ) - -(put 'eieio--defalias 'byte-hunk-handler - #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) -(defun eieio--defalias (name body) - "Like `defalias', but with less side-effects. -More specifically, it has no side-effects at all when the new function -definition is the same (`eq') as the old one." - (unless (and (fboundp name) - (eq (symbol-function name) body)) - (defalias name body))) +(require 'cl-lib) +(require 'pcase) ;;; ;; A few functions that are better in the official EIEIO src, but @@ -85,8 +62,12 @@ default setting for optimization purposes.") (defvar eieio-optimize-primary-methods-flag t "Non-nil means to optimize the method dispatch on primary methods.") -(defvar eieio-initializing-object nil - "Set to non-nil while initializing an object.") +(defvar eieio-backward-compatibility t + "If nil, drop support for some behaviors of older versions of EIEIO. +Currently under control of this var: +- Define every class as a var whose value is the class symbol. +- Define <class>-child-p and <class>-list-p predicates. +- Allow object names in constructors.") (defconst eieio-unbound (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) @@ -98,110 +79,78 @@ default setting for optimization purposes.") ;; while it is being built itself. (defvar eieio-default-superclass nil) -;;; -;; Class currently in scope. -;; -;; When invoking methods, the running method needs to know which class -;; is currently in scope. Generally this is the class of the method -;; being called, but 'call-next-method' needs to query this state, -;; and change it to be then next super class up. -;; -;; Thus, the scoped class is a stack that needs to be managed. +(progn + ;; Arrange for field access not to bother checking if the access is indeed + ;; made to an eieio--class object. + (cl-declaim (optimize (safety 0))) +(cl-defstruct (eieio--class + (:constructor nil) + (:constructor eieio--class-make (symbol &aux (tag 'defclass))) + (:type vector) + (:copier nil)) + ;; We use an untagged cl-struct, with our own hand-made tag as first field + ;; (containing the symbol `defclass'). It would be better to use a normal + ;; cl-struct with its normal tag (e.g. so that cl-defstruct can define the + ;; predicate for us), but that breaks compatibility with .elc files compiled + ;; against older versions of EIEIO. + tag + symbol ;; symbol (self-referencing) + parent children + symbol-hashtable ;; hashtable permitting fast access to variable position indexes + ;; @todo + ;; the word "public" here is leftovers from the very first version. + ;; Get rid of it! + public-a ;; class attribute index + public-d ;; class attribute defaults index + public-doc ;; class documentation strings for attributes + public-type ;; class type for a slot + public-custom ;; class custom type for a slot + public-custom-label ;; class custom group for a slot + public-custom-group ;; class custom group for a slot + public-printer ;; printer for a slot + protection ;; protection for a slot + initarg-tuples ;; initarg tuples list + class-allocation-a ;; class allocated attributes + class-allocation-doc ;; class allocated documentation + class-allocation-type ;; class allocated value type + class-allocation-custom ;; class allocated custom descriptor + class-allocation-custom-label ;; class allocated custom descriptor + class-allocation-custom-group ;; class allocated custom group + class-allocation-printer ;; class allocated printer for a slot + class-allocation-protection ;; class allocated protection list + class-allocation-values ;; class allocated value vector + default-object-cache ;; what a newly created object would look like. + ; This will speed up instantiation time as + ; only a `copy-sequence' will be needed, instead of + ; looping over all the values and setting them from + ; the default. + options ;; storage location of tagged class option + ; Stored outright without modifications or stripping + ) + ;; Set it back to the default value. + (cl-declaim (optimize (safety 1)))) -(defvar eieio--scoped-class-stack nil - "A stack of the classes currently in scope during method invocation.") -(defun eieio--scoped-class () - "Return the class currently in scope, or nil." - (car-safe eieio--scoped-class-stack)) +(cl-defstruct (eieio--object + (:type vector) ;We manage our own tagging system. + (:constructor nil) + (:copier nil)) + ;; `class-tag' holds a symbol, which is not the class name, but is instead + ;; properly prefixed as an internal EIEIO thingy and which holds the class + ;; object/struct in its `symbol-value' slot. + class-tag) -(defmacro eieio--with-scoped-class (class &rest forms) - "Set CLASS as the currently scoped class while executing FORMS." - `(unwind-protect - (progn - (push ,class eieio--scoped-class-stack) - ,@forms) - (pop eieio--scoped-class-stack))) -(put 'eieio--with-scoped-class 'lisp-indent-function 1) +(eval-and-compile + (defconst eieio--object-num-slots + (length (get 'eieio--object 'cl-struct-slots)))) -;;; -;; Field Accessors -;; -(defmacro eieio--define-field-accessors (prefix fields) - (declare (indent 1)) - (let ((index 0) - (defs '())) - (dolist (field fields) - (let ((doc (if (listp field) - (prog1 (cadr field) (setq field (car field)))))) - (push `(defmacro ,(intern (format "eieio--%s-%s" prefix field)) (x) - ,@(if doc (list (format (if (string-match "\n" doc) - "Return %s" "Return %s of a %s.") - doc prefix))) - (list 'aref x ,index)) - defs) - (setq index (1+ index)))) - `(eval-and-compile - ,@(nreverse defs) - (defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index)))) - -(eieio--define-field-accessors class - (-unused-0 ;;FIXME: not sure, but at least there was no accessor! - (symbol "symbol (self-referencing)") - parent children - (symbol-obarray "obarray permitting fast access to variable position indexes") - ;; @todo - ;; the word "public" here is leftovers from the very first version. - ;; Get rid of it! - (public-a "class attribute index") - (public-d "class attribute defaults index") - (public-doc "class documentation strings for attributes") - (public-type "class type for a slot") - (public-custom "class custom type for a slot") - (public-custom-label "class custom group for a slot") - (public-custom-group "class custom group for a slot") - (public-printer "printer for a slot") - (protection "protection for a slot") - (initarg-tuples "initarg tuples list") - (class-allocation-a "class allocated attributes") - (class-allocation-doc "class allocated documentation") - (class-allocation-type "class allocated value type") - (class-allocation-custom "class allocated custom descriptor") - (class-allocation-custom-label "class allocated custom descriptor") - (class-allocation-custom-group "class allocated custom group") - (class-allocation-printer "class allocated printer for a slot") - (class-allocation-protection "class allocated protection list") - (class-allocation-values "class allocated value vector") - (default-object-cache "what a newly created object would look like. -This will speed up instantiation time as only a `copy-sequence' will -be needed, instead of looping over all the values and setting them -from the default.") - (options "storage location of tagged class options. -Stored outright without modifications or stripping."))) - -(eieio--define-field-accessors object - (-unused-0 ;;FIXME: not sure, but at least there was no accessor! - (class "class struct defining OBJ") - name)) - -;; FIXME: The constants below should have an `eieio-' prefix added!! - -(defconst method-static 0 "Index into :static tag on a method.") -(defconst method-before 1 "Index into :before tag on a method.") -(defconst method-primary 2 "Index into :primary tag on a method.") -(defconst method-after 3 "Index into :after tag on a method.") -(defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.") -(defconst method-generic-before 4 "Index into generic :before tag on a method.") -(defconst method-generic-primary 5 "Index into generic :primary tag on a method.") -(defconst method-generic-after 6 "Index into generic :after tag on a method.") -(defconst method-num-slots 7 "Number of indexes into a method's vector.") - -(defsubst eieio-specialized-key-to-generic-key (key) - "Convert a specialized KEY into a generic method key." - (cond ((eq key method-static) 0) ;; don't convert - ((< key method-num-lists) (+ key 3)) ;; The conversion - (t key) ;; already generic.. maybe. - )) +(defsubst eieio--object-class-object (obj) + (symbol-value (eieio--object-class-tag obj))) + +(defsubst eieio--object-class-name (obj) + ;; FIXME: Most uses of this function should be changed to use + ;; eieio--object-class-object instead! + (eieio--class-symbol (eieio--object-class-object obj))) ;;; Important macros used internally in eieio. @@ -215,120 +164,94 @@ Stored outright without modifications or stripping."))) (t `(,type ,obj)))) (signal 'wrong-type-argument (list ',type ,obj)))) -(defmacro class-v (class) +(defmacro eieio--class-v (class) ;Use a macro, so it acts as a GV place. "Internal: Return the class vector from the CLASS symbol." + (declare (debug t)) ;; No check: If eieio gets this far, it has probably been checked already. `(get ,class 'eieio-class-definition)) -(defmacro class-p (class) - "Return t if CLASS is a valid class vector. -CLASS is a symbol." +(defsubst eieio--class-object (class) + "Return the class object." + (if (symbolp class) + ;; Keep the symbol if class-v is nil, for better error messages. + (or (eieio--class-v class) class) + class)) + +(defsubst eieio--class-p (class) + "Return non-nil if CLASS is a valid class object." + (condition-case nil + (eq (aref class 0) 'defclass) + (error nil))) + +(defsubst eieio-class-object (class) + "Check that CLASS is a class and return the corresponding object." + (let ((c (eieio--class-object class))) + (eieio--check-type eieio--class-p c) + c)) + +(defsubst class-p (class) + "Return non-nil if CLASS is a valid class vector. +CLASS is a symbol." ;FIXME: Is it a vector or a symbol? ;; this new method is faster since it doesn't waste time checking lots of ;; things. - `(condition-case nil - (eq (aref (class-v ,class) 0) 'defclass) - (error nil))) - -(defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS." + (condition-case nil + (eq (aref (eieio--class-v class) 0) 'defclass) + (error nil))) + +(defun eieio-class-name (class) + "Return a Lisp like symbol name for CLASS." + ;; FIXME: What's a "Lisp like symbol name"? + ;; FIXME: CLOS returns a symbol, but the code returns a string. + (if (eieio--class-p class) (setq class (eieio--class-symbol class))) (eieio--check-type class-p class) ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, ;; and I wanted a string. Arg! (format "#<class %s>" (symbol-name class))) (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") -(defmacro eieio-class-parents-fast (class) - "Return parent classes to CLASS with no check." - `(eieio--class-parent (class-v ,class))) - -(defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check." - `(eieio--class-children (class-v ,class))) - -(defmacro same-class-fast-p (obj class) - "Return t if OBJ is of class-type CLASS with no error checking." - `(eq (eieio--object-class ,obj) ,class)) - -(defmacro class-constructor (class) - "Return the symbol representing the constructor of CLASS." - `(eieio--class-symbol (class-v ,class))) - -(defmacro generic-p (method) - "Return t if symbol METHOD is a generic function. -Only methods have the symbol `eieio-method-obarray' as a property -\(which contains a list of all bindings to that method type.)" - `(and (fboundp ,method) (get ,method 'eieio-method-obarray))) - -(defun generic-primary-only-p (method) - "Return t if symbol METHOD is a generic function with only primary methods. -Only methods have the symbol `eieio-method-obarray' as a property (which -contains a list of all bindings to that method type.) -Methods with only primary implementations are executed in an optimized way." - (and (generic-p method) - (let ((M (get method 'eieio-method-tree))) - (and (< 0 (length (aref M method-primary))) - (not (aref M method-static)) - (not (aref M method-before)) - (not (aref M method-after)) - (not (aref M method-generic-before)) - (not (aref M method-generic-primary)) - (not (aref M method-generic-after)))) - )) - -(defun generic-primary-only-one-p (method) - "Return t if symbol METHOD is a generic function with only primary methods. -Only methods have the symbol `eieio-method-obarray' as a property (which -contains a list of all bindings to that method type.) -Methods with only primary implementations are executed in an optimized way." - (and (generic-p method) - (let ((M (get method 'eieio-method-tree))) - (and (= 1 (length (aref M method-primary))) - (not (aref M method-static)) - (not (aref M method-before)) - (not (aref M method-after)) - (not (aref M method-generic-before)) - (not (aref M method-generic-primary)) - (not (aref M method-generic-after)))) - )) - -(defmacro class-option-assoc (list option) +(defalias 'eieio--class-constructor #'identity + "Return the symbol representing the constructor of CLASS.") + +(defmacro eieio--class-option-assoc (list option) "Return from LIST the found OPTION, or nil if it doesn't exist." `(car-safe (cdr (memq ,option ,list)))) -(defmacro class-option (class option) +(defsubst eieio--class-option (class option) "Return the value stored for CLASS' OPTION. Return nil if that option doesn't exist." - `(class-option-assoc (eieio--class-options (class-v ,class)) ',option)) + (eieio--class-option-assoc (eieio--class-options class) option)) -(defmacro eieio-object-p (obj) +(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))) + (and (vectorp obj) + (condition-case nil + (eq (aref (eieio--object-class-object obj) 0) 'defclass) + (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)) + (eieio--class-option (eieio--class-v class) :abstract)) -(defmacro class-method-invocation-order (class) +(defsubst eieio--class-method-invocation-order (class) "Return the invocation order of CLASS. Abstract classes cannot be instantiated." - `(or (class-option ,class :method-invocation-order) - :breadth-first)) + (or (eieio--class-option class :method-invocation-order) + :breadth-first)) ;;; ;; Class Creation -(defvar eieio-defclass-autoload-map (make-vector 7 nil) +(defvar eieio-defclass-autoload-map (make-hash-table) "Symbol map of superclasses we find in autoloads.") ;; We autoload this because it's used in `make-autoload'. ;;;###autoload -(defun eieio-defclass-autoload (cname superclasses filename doc) +(defun eieio-defclass-autoload (cname _superclasses filename doc) "Create autoload symbols for the EIEIO class CNAME. SUPERCLASSES are the superclasses that CNAME inherits from. DOC is the docstring for CNAME. @@ -337,82 +260,52 @@ SUPERCLASSES as children. It creates an autoload function for CNAME's constructor." ;; Assume we've already debugged inputs. - (let* ((oldc (when (class-p cname) (class-v cname))) - (newc (make-vector eieio--class-num-slots nil)) + ;; We used to store the list of superclasses in the `parent' slot (as a list + ;; of class names). But now this slot holds a list of class objects, and + ;; those parents may not exist yet, so the corresponding class objects may + ;; simply not exist yet. So instead we just don't store the list of parents + ;; here in eieio-defclass-autoload at all, since it seems that they're just + ;; not needed before the class is actually loaded. + (let* ((oldc (when (class-p cname) (eieio--class-v cname))) + (newc (eieio--class-make cname)) ) (if oldc nil ;; Do nothing if we already have this class. - ;; Create the class in NEWC, but don't fill anything else in. - (aset newc 0 'defclass) - (setf (eieio--class-symbol newc) cname) - - (let ((clear-parent nil)) - ;; No parents? - (when (not superclasses) - (setq superclasses '(eieio-default-superclass) - clear-parent t) - ) - - ;; Hook our new class into the existing structures so we can - ;; autoload it later. - (dolist (SC superclasses) - - - ;; TODO - If we create an autoload that is in the map, that - ;; map needs to be cleared! - + ;; turn this into a usable self-pointing symbol + (when eieio-backward-compatibility + (set cname cname) + (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) - ;; Does our parent exist? - (if (not (class-p SC)) + ;; Store the new class vector definition into the symbol. We need to + ;; do this first so that we can call defmethod for the accessor. + ;; The vector will be updated by the following while loop and will not + ;; need to be stored a second time. + (setf (eieio--class-v cname) newc) - ;; Create a symbol for this parent, and then store this - ;; parent on that symbol. - (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map))) - (if (not (boundp sym)) - (set sym (list cname)) - (add-to-list sym cname)) - ) - - ;; We have a parent, save the child in there. - (when (not (member cname (eieio--class-children (class-v SC)))) - (setf (eieio--class-children (class-v SC)) - (cons cname (eieio--class-children (class-v SC)))))) - - ;; save parent in child - (setf (eieio--class-parent newc) (cons SC (eieio--class-parent newc))) - ) - - ;; turn this into a usable self-pointing symbol - (set cname cname) - - ;; Store the new class vector definition into the symbol. We need to - ;; do this first so that we can call defmethod for the accessor. - ;; The vector will be updated by the following while loop and will not - ;; need to be stored a second time. - (put cname 'eieio-class-definition newc) - - ;; Clear the parent - (if clear-parent (setf (eieio--class-parent newc) nil)) - - ;; Create an autoload on top of our constructor function. - (autoload cname filename doc nil nil) - (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) - (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) - (autoload (intern (concat (symbol-name cname) "-list-p")) filename "" nil nil) - - )))) + ;; Create an autoload on top of our constructor function. + (autoload cname filename doc nil nil) + (autoload (intern (format "%s-p" cname)) filename "" nil nil) + (when eieio-backward-compatibility + (autoload (intern (format "%s-child-p" cname)) filename "" nil nil) + (autoload (intern (format "%s-list-p" cname)) filename "" nil nil))))) (defsubst eieio-class-un-autoload (cname) "If class CNAME is in an autoload state, load its file." - (when (eq (car-safe (symbol-function cname)) 'autoload) - (load-library (car (cdr (symbol-function cname)))))) + (autoload-do-load (symbol-function cname))) ; cname + +(cl-deftype list-of (elem-type) + `(and list + (satisfies (lambda (list) + (cl-every (lambda (elem) (cl-typep elem ',elem-type)) + list))))) -(defun eieio-defclass (cname superclasses slots options-and-doc) - ;; FIXME: Most of this should be moved to the `defclass' macro. +(declare-function eieio--defmethod "eieio-generic" (method kind argclass code)) + +(defun eieio-defclass-internal (cname superclasses slots options) "Define CNAME as a new subclass of SUPERCLASSES. -SLOTS are the slots residing in that class definition, and options or -documentation OPTIONS-AND-DOC is the toplevel documentation for this class. +SLOTS are the slots residing in that class definition, and OPTIONS +holds the class options. See `defclass' for more information." ;; Run our eieio-hook each time, and clear it when we are done. ;; This way people can add hooks safely if they want to modify eieio @@ -420,18 +313,17 @@ See `defclass' for more information." (run-hooks 'eieio-hook) (setq eieio-hook nil) - (eieio--check-type listp superclasses) - (let* ((pname superclasses) - (newc (make-vector eieio--class-num-slots nil)) - (oldc (when (class-p cname) (class-v cname))) + (oldc (when (class-p cname) (eieio--class-v cname))) + (newc (if (and oldc (not (eieio--class-default-object-cache oldc))) + ;; The oldc class is a stub setup by eieio-defclass-autoload. + ;; Reuse it instead of creating a new one, so that existing + ;; references are still valid. + oldc + (eieio--class-make cname))) (groups nil) ;; list of groups id'd from slots - (options nil) (clearparent nil)) - (aset newc 0 'defclass) - (setf (eieio--class-symbol newc) cname) - ;; If this class already existed, and we are updating its structure, ;; make sure we keep the old child list. This can cause bugs, but ;; if no new slots are created, it also saves time, and prevents @@ -439,124 +331,68 @@ See `defclass' for more information." ;; byte compiling an EIEIO file. (if oldc (setf (eieio--class-children newc) (eieio--class-children oldc)) - ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. - ;; This is like the above, but deals with autoloads nicely. - (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) - (when sym - (condition-case nil - (setf (eieio--class-children newc) (symbol-value sym)) - (error nil)) - (unintern (symbol-name cname) eieio-defclass-autoload-map) - )) - ) - - (cond ((and (stringp (car options-and-doc)) - (/= 1 (% (length options-and-doc) 2))) - (error "Too many arguments to `defclass'")) - ((and (symbolp (car options-and-doc)) - (/= 0 (% (length options-and-doc) 2))) - (error "Too many arguments to `defclass'")) - ) - - (setq options - (if (stringp (car options-and-doc)) - (cons :documentation options-and-doc) - options-and-doc)) + ;; If the old class did not exist, but did exist in the autoload map, + ;; then adopt those children. This is like the above, but deals with + ;; autoloads nicely. + (let ((children (gethash cname eieio-defclass-autoload-map))) + (when children + (setf (eieio--class-children newc) children) + (remhash cname eieio-defclass-autoload-map)))) (if pname (progn - (while pname - (if (and (car pname) (symbolp (car pname))) - (if (not (class-p (car pname))) + (dolist (p pname) + (if (and p (symbolp p)) + (if (not (class-p p)) ;; bad class - (error "Given parent class %s is not a class" (car pname)) + (error "Given parent class %S is not a class" p) ;; good parent class... ;; save new child in parent - (when (not (member cname (eieio--class-children (class-v (car pname))))) - (setf (eieio--class-children (class-v (car pname))) - (cons cname (eieio--class-children (class-v (car pname)))))) + (cl-pushnew cname (eieio--class-children (eieio--class-v p))) ;; Get custom groups, and store them into our local copy. - (mapc (lambda (g) (pushnew g groups :test #'equal)) - (class-option (car pname) :custom-groups)) + (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) + (eieio--class-option (eieio--class-v p) :custom-groups)) ;; save parent in child - (setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc)))) - (error "Invalid parent class %s" pname)) - (setq pname (cdr pname))) + (push (eieio--class-v p) (eieio--class-parent newc))) + (error "Invalid parent class %S" p))) ;; Reverse the list of our parents so that they are prioritized in ;; the same order as specified in the code. - (setf (eieio--class-parent newc) (nreverse (eieio--class-parent newc))) ) + (cl-callf nreverse (eieio--class-parent newc))) ;; If there is nothing to loop over, then inherit from the ;; default superclass. (unless (eq cname 'eieio-default-superclass) ;; adopt the default parent here, but clear it later... (setq clearparent t) - ;; save new child in parent - (if (not (member cname (eieio--class-children (class-v 'eieio-default-superclass)))) - (setf (eieio--class-children (class-v 'eieio-default-superclass)) - (cons cname (eieio--class-children (class-v 'eieio-default-superclass))))) - ;; save parent in child - (setf (eieio--class-parent newc) (list eieio-default-superclass)))) - - ;; turn this into a usable self-pointing symbol - (set cname cname) - - ;; These two tests must be created right away so we can have self- - ;; referencing classes. ei, a class whose slot can contain only - ;; pointers to itself. - - ;; Create the test function - (let ((csym (intern (concat (symbol-name cname) "-p")))) - (fset csym - (list 'lambda (list 'obj) - (format "Test OBJ to see if it an object of type %s" cname) - (list 'and '(eieio-object-p obj) - (list 'same-class-p 'obj cname))))) - - ;; Make sure the method invocation order is a valid value. - (let ((io (class-option-assoc options :method-invocation-order))) - (when (and io (not (member io '(:depth-first :breadth-first :c3)))) - (error "Method invocation order %s is not allowed" io) - )) + ;; save new child in parent + (cl-pushnew cname (eieio--class-children eieio-default-superclass)) + ;; save parent in child + (setf (eieio--class-parent newc) (list eieio-default-superclass)))) - ;; Create a handy child test too - (let ((csym (intern (concat (symbol-name cname) "-child-p")))) - (fset csym - `(lambda (obj) - ,(format - "Test OBJ to see if it an object is a child of type %s" - cname) - (and (eieio-object-p obj) - (object-of-class-p obj ,cname)))) + ;; turn this into a usable self-pointing symbol; FIXME: Why? + (when eieio-backward-compatibility + (set cname cname) + (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) ;; Create a handy list of the class test too - (let ((csym (intern (concat (symbol-name cname) "-list-p")))) - (fset csym - `(lambda (obj) - ,(format - "Test OBJ to see if it a list of objects which are a child of type %s" - cname) - (when (listp obj) - (let ((ans t)) ;; nil is valid - ;; Loop over all the elements of the input list, test - ;; each to make sure it is a child of the desired object class. - (while (and obj ans) - (setq ans (and (eieio-object-p (car obj)) - (object-of-class-p (car obj) ,cname))) - (setq obj (cdr obj))) - ans))))) - - ;; When using typep, (typep OBJ 'myclass) returns t for objects which - ;; are subclasses of myclass. For our predicates, however, it is - ;; important for EIEIO to be backwards compatible, where - ;; myobject-p, and myobject-child-p are different. - ;; "cl" uses this technique to specify symbols with specific typep - ;; test, so we can let typep have the CLOS documented behavior - ;; while keeping our above predicate clean. - - ;; It would be cleaner to use `defsetf' here, but that requires cl - ;; at runtime. - (put cname 'cl-deftype-handler - (list 'lambda () `(list 'satisfies (quote ,csym))))) + (when eieio-backward-compatibility + (let ((csym (intern (concat (symbol-name cname) "-list-p")))) + (defalias csym + `(lambda (obj) + ,(format + "Test OBJ to see if it a list of objects which are a child of type %s" + cname) + (when (listp obj) + (let ((ans t)) ;; nil is valid + ;; Loop over all the elements of the input list, test + ;; each to make sure it is a child of the desired object class. + (while (and obj ans) + (setq ans (and (eieio-object-p (car obj)) + (object-of-class-p (car obj) ,cname))) + (setq obj (cdr obj))) + ans)))) + (make-obsolete csym (format "use (cl-typep ... '(list-of %s)) instead" + cname) + "25.1"))) ;; Before adding new slots, let's add all the methods and classes ;; in from the parent class. @@ -566,78 +402,45 @@ See `defclass' for more information." ;; do this first so that we can call defmethod for the accessor. ;; The vector will be updated by the following while loop and will not ;; need to be stored a second time. - (put cname 'eieio-class-definition newc) + (setf (eieio--class-v cname) newc) ;; Query each slot in the declaration list and mangle into the ;; class structure I have defined. - (while slots - (let* ((slot1 (car slots)) - (name (car slot1)) - (slot (cdr slot1)) - (acces (plist-get slot ':accessor)) - (init (or (plist-get slot ':initform) - (if (member ':initform slot) nil + (pcase-dolist (`(,name . ,slot) slots) + (let* ((init (or (plist-get slot :initform) + (if (member :initform slot) nil eieio-unbound))) - (initarg (plist-get slot ':initarg)) - (docstr (plist-get slot ':documentation)) - (prot (plist-get slot ':protection)) - (reader (plist-get slot ':reader)) - (writer (plist-get slot ':writer)) - (alloc (plist-get slot ':allocation)) - (type (plist-get slot ':type)) - (custom (plist-get slot ':custom)) - (label (plist-get slot ':label)) - (customg (plist-get slot ':group)) - (printer (plist-get slot ':printer)) - - (skip-nil (class-option-assoc options :allow-nil-initform)) + (initarg (plist-get slot :initarg)) + (docstr (plist-get slot :documentation)) + (prot (plist-get slot :protection)) + (alloc (plist-get slot :allocation)) + (type (plist-get slot :type)) + (custom (plist-get slot :custom)) + (label (plist-get slot :label)) + (customg (plist-get slot :group)) + (printer (plist-get slot :printer)) + + (skip-nil (eieio--class-option-assoc options :allow-nil-initform)) ) - (if eieio-error-unsupported-class-tags - (let ((tmp slot)) - (while tmp - (if (not (member (car tmp) '(:accessor - :initform - :initarg - :documentation - :protection - :reader - :writer - :allocation - :type - :custom - :label - :group - :printer - :allow-nil-initform - :custom-groups))) - (signal 'invalid-slot-type (list (car tmp)))) - (setq tmp (cdr (cdr tmp)))))) - ;; Clean up the meaning of protection. - (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil)) - ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) - ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) - ((eq prot nil) nil) - (t (signal 'invalid-slot-type (list ':protection prot)))) - - ;; Make sure the :allocation parameter has a valid value. - (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) - (signal 'invalid-slot-type (list ':allocation alloc))) + (setq prot + (pcase prot + ((or 'nil 'public ':public) nil) + ((or 'protected ':protected) 'protected) + ((or 'private ':private) 'private) + (_ (signal 'invalid-slot-type (list :protection prot))))) ;; The default type specifier is supposed to be t, meaning anything. (if (not type) (setq type t)) - ;; Label is nil, or a string - (if (not (or (null label) (stringp label))) - (signal 'invalid-slot-type (list ':label label))) - - ;; Is there an initarg, but allocation of class? - (if (and initarg (eq alloc :class)) - (message "Class allocated slots do not need :initarg")) - ;; intern the symbol so we can use it blankly - (if initarg (set initarg initarg)) + (if eieio-backward-compatibility + (and initarg (not (keywordp initarg)) + (progn + (set initarg initarg) + (make-obsolete-variable + initarg (format "use '%s instead" initarg) "25.1")))) ;; The customgroup should be a list of symbols (cond ((null customg) @@ -647,145 +450,60 @@ See `defclass' for more information." ;; The customgroup better be a symbol, or list of symbols. (mapc (lambda (cg) (if (not (symbolp cg)) - (signal 'invalid-slot-type (list ':group cg)))) + (signal 'invalid-slot-type (list :group cg)))) customg) ;; First up, add this slot into our new class. - (eieio-add-new-slot newc name init docstr type custom label customg printer + (eieio--add-new-slot newc name init docstr type custom label customg printer prot initarg alloc 'defaultoverride skip-nil) ;; We need to id the group, and store them in a group list attribute. - (mapc (lambda (cg) (pushnew cg groups :test 'equal)) customg) - - ;; Anyone can have an accessor function. This creates a function - ;; of the specified name, and also performs a `defsetf' if applicable - ;; so that users can `setf' the space returned by this function. - (if acces - (progn - (eieio--defmethod - acces (if (eq alloc :class) :static :primary) cname - `(lambda (this) - ,(format - "Retrieves the slot `%s' from an object of class `%s'" - name cname) - (if (slot-boundp this ',name) - (eieio-oref this ',name) - ;; Else - Some error? nil? - nil))) - - (if (fboundp 'gv-define-setter) - ;; FIXME: We should move more of eieio-defclass into the - ;; defclass macro so we don't have to use `eval' and require - ;; `gv' at run-time. - (eval `(gv-define-setter ,acces (eieio--store eieio--object) - (list 'eieio-oset eieio--object '',name - eieio--store))) - ;; Provide a setf method. It would be cleaner to use - ;; defsetf, but that would require CL at runtime. - (put acces 'setf-method - `(lambda (widget) - (let* ((--widget-sym-- (make-symbol "--widget--")) - (--store-sym-- (make-symbol "--store--"))) - (list - (list --widget-sym--) - (list widget) - (list --store-sym--) - (list 'eieio-oset --widget-sym-- '',name - --store-sym--) - (list 'getfoo --widget-sym--)))))))) - - ;; If a writer is defined, then create a generic method of that - ;; name whose purpose is to set the value of the slot. - (if writer - (eieio--defmethod - writer nil cname - `(lambda (this value) - ,(format "Set the slot `%s' of an object of class `%s'" - name cname) - (setf (slot-value this ',name) value)))) - ;; If a reader is defined, then create a generic method - ;; of that name whose purpose is to access this slot value. - (if reader - (eieio--defmethod - reader nil cname - `(lambda (this) - ,(format "Access the slot `%s' from object of class `%s'" - name cname) - (slot-value this ',name)))) - ) - (setq slots (cdr slots))) + (dolist (cg customg) + (cl-pushnew cg groups :test 'equal)) + )) ;; Now that everything has been loaded up, all our lists are backwards! ;; Fix that up now. - (setf (eieio--class-public-a newc) (nreverse (eieio--class-public-a newc))) - (setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc))) - (setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc newc))) - (setf (eieio--class-public-type newc) - (apply 'vector (nreverse (eieio--class-public-type newc)))) - (setf (eieio--class-public-custom newc) (nreverse (eieio--class-public-custom newc))) - (setf (eieio--class-public-custom-label newc) (nreverse (eieio--class-public-custom-label newc))) - (setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc))) - (setf (eieio--class-public-printer newc) (nreverse (eieio--class-public-printer newc))) - (setf (eieio--class-protection newc) (nreverse (eieio--class-protection newc))) - (setf (eieio--class-initarg-tuples newc) (nreverse (eieio--class-initarg-tuples newc))) + (cl-callf nreverse (eieio--class-public-a newc)) + (cl-callf nreverse (eieio--class-public-d newc)) + (cl-callf nreverse (eieio--class-public-doc newc)) + (cl-callf (lambda (types) (apply #'vector (nreverse types))) + (eieio--class-public-type newc)) + (cl-callf nreverse (eieio--class-public-custom newc)) + (cl-callf nreverse (eieio--class-public-custom-label newc)) + (cl-callf nreverse (eieio--class-public-custom-group newc)) + (cl-callf nreverse (eieio--class-public-printer newc)) + (cl-callf nreverse (eieio--class-protection newc)) + (cl-callf nreverse (eieio--class-initarg-tuples newc)) ;; The storage for class-class-allocation-type needs to be turned into ;; a vector now. - (setf (eieio--class-class-allocation-type newc) - (apply 'vector (eieio--class-class-allocation-type newc))) + (cl-callf (lambda (cat) (apply #'vector cat)) + (eieio--class-class-allocation-type newc)) ;; Also, take class allocated values, and vectorize them for speed. - (setf (eieio--class-class-allocation-values newc) - (apply 'vector (eieio--class-class-allocation-values newc))) - - ;; Attach slot symbols into an obarray, and store the index of - ;; this slot as the variable slot in this new symbol. We need to - ;; know about primes, because obarrays are best set in vectors of - ;; prime number length, and we also need to make our vector small - ;; to save space, and also optimal for the number of items we have. + (cl-callf (lambda (cavs) (apply #'vector cavs)) + (eieio--class-class-allocation-values newc)) + + ;; Attach slot symbols into a hashtable, and store the index of + ;; this slot as the value this table. (let* ((cnt 0) (pubsyms (eieio--class-public-a newc)) (prots (eieio--class-protection newc)) - (l (length pubsyms)) - (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47 - 53 59 61 67 71 73 79 83 89 97 101 ))) - (while (and primes (< (car primes) l)) - (setq primes (cdr primes))) - (car primes))) - (oa (make-vector vl 0)) - (newsym)) + (oa (make-hash-table :test #'eq))) (while pubsyms - (setq newsym (intern (symbol-name (car pubsyms)) oa)) - (set newsym cnt) - (setq cnt (1+ cnt)) - (if (car prots) (put newsym 'protection (car prots))) + (let ((newsym (list cnt))) + (setf (gethash (car pubsyms) oa) newsym) + (setq cnt (1+ cnt)) + (if (car prots) (setcdr newsym (car prots)))) (setq pubsyms (cdr pubsyms) prots (cdr prots))) - (setf (eieio--class-symbol-obarray newc) oa) - ) - - ;; Create the constructor function - (if (class-option-assoc options :abstract) - ;; Abstract classes cannot be instantiated. Say so. - (let ((abs (class-option-assoc options :abstract))) - (if (not (stringp abs)) - (setq abs (format "Class %s is abstract" cname))) - (fset cname - `(lambda (&rest stuff) - ,(format "You cannot create a new object of type %s" cname) - (error ,abs)))) - - ;; Non-abstract classes need a constructor. - (fset cname - `(lambda (newname &rest slots) - ,(format "Create a new object with name NAME of class type %s" cname) - (apply 'constructor ,cname newname slots))) - ) + (setf (eieio--class-symbol-hashtable newc) oa)) ;; Set up a specialized doc string. ;; Use stored value since it is calculated in a non-trivial way (put cname 'variable-documentation - (class-option-assoc options :documentation)) + (eieio--class-option-assoc options :documentation)) ;; Save the file location where this class is defined. (let ((fname (if load-in-progress @@ -797,8 +515,8 @@ See `defclass' for more information." (put cname 'class-location fname))) ;; We have a list of custom groups. Store them into the options. - (let ((g (class-option-assoc options :custom-groups))) - (mapc (lambda (cg) (pushnew cg g :test 'equal)) groups) + (let ((g (eieio--class-option-assoc options :custom-groups))) + (mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups) (if (memq :custom-groups options) (setcar (cdr (memq :custom-groups options)) g) (setq options (cons :custom-groups (cons g options))))) @@ -811,11 +529,17 @@ See `defclass' for more information." (if clearparent (setf (eieio--class-parent newc) nil)) ;; Create the cached default object. - (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) 3) - nil))) - (aset cache 0 'object) - (setf (eieio--object-class cache) cname) - (setf (eieio--object-name cache) 'default-cache-object) + (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) + (eval-when-compile eieio--object-num-slots)) + nil)) + ;; We don't strictly speaking need to use a symbol, but the old + ;; code used the class's name rather than the class's object, so + ;; we follow this preference for using a symbol, which is probably + ;; convenient to keep the printed representation of such Elisp + ;; objects readable. + (tag (intern (format "eieio-class-tag--%s" cname)))) + (set tag newc) + (setf (eieio--object-class-tag cache) tag) (let ((eieio-skip-typecheck t)) ;; All type-checking has been done to our satisfaction ;; before this call. Don't waste our time in this call.. @@ -831,16 +555,16 @@ See `defclass' for more information." "Whether the default value VAL should be evaluated for use." (and (consp val) (symbolp (car val)) (fboundp (car val)))) -(defun eieio-perform-slot-validation-for-default (slot spec value skipnil) +(defun eieio--perform-slot-validation-for-default (slot spec value skipnil) "For SLOT, signal if SPEC does not match VALUE. If SKIPNIL is non-nil, then if VALUE is nil return t instead." - (if (and (not (eieio-eval-default-p value)) - (not eieio-skip-typecheck) - (not (and skipnil (null value))) - (not (eieio-perform-slot-validation spec value))) + (if (not (or (eieio-eval-default-p value) ;FIXME: Why? + eieio-skip-typecheck + (and skipnil (null value)) + (eieio--perform-slot-validation spec value))) (signal 'invalid-slot-type (list slot spec value)))) -(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc +(defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc &optional defaultoverride skipnil) "Add into NEWC attribute A. If A already exists in NEWC, then do nothing. If it doesn't exist, @@ -861,9 +585,9 @@ if default value is nil." ;; To prevent override information w/out specification of storage, ;; we need to do this little hack. - (if (member a (eieio--class-class-allocation-a newc)) (setq alloc ':class)) + (if (member a (eieio--class-class-allocation-a newc)) (setq alloc :class)) - (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) + (if (or (not alloc) (and (symbolp alloc) (eq alloc :instance))) ;; In this case, we modify the INSTANCE version of a given slot. (progn @@ -871,16 +595,16 @@ if default value is nil." ;; Only add this element if it is so-far unique (if (not (member a (eieio--class-public-a newc))) (progn - (eieio-perform-slot-validation-for-default a type d skipnil) - (setf (eieio--class-public-a newc) (cons a (eieio--class-public-a newc))) - (setf (eieio--class-public-d newc) (cons d (eieio--class-public-d newc))) - (setf (eieio--class-public-doc newc) (cons doc (eieio--class-public-doc newc))) - (setf (eieio--class-public-type newc) (cons type (eieio--class-public-type newc))) - (setf (eieio--class-public-custom newc) (cons cust (eieio--class-public-custom newc))) - (setf (eieio--class-public-custom-label newc) (cons label (eieio--class-public-custom-label newc))) - (setf (eieio--class-public-custom-group newc) (cons custg (eieio--class-public-custom-group newc))) - (setf (eieio--class-public-printer newc) (cons print (eieio--class-public-printer newc))) - (setf (eieio--class-protection newc) (cons prot (eieio--class-protection newc))) + (eieio--perform-slot-validation-for-default a type d skipnil) + (push a (eieio--class-public-a newc)) + (push d (eieio--class-public-d newc)) + (push doc (eieio--class-public-doc newc)) + (push type (eieio--class-public-type newc)) + (push cust (eieio--class-public-custom newc)) + (push label (eieio--class-public-custom-label newc)) + (push custg (eieio--class-public-custom-group newc)) + (push print (eieio--class-public-printer newc)) + (push prot (eieio--class-protection newc)) (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) ) ;; When defaultoverride is true, we are usually adding new local @@ -906,7 +630,7 @@ if default value is nil." type tp a))) ;; If we have a repeat, only update the initarg... (unless (eq d eieio-unbound) - (eieio-perform-slot-validation-for-default a tp d skipnil) + (eieio--perform-slot-validation-for-default a tp d skipnil) (setcar dp d)) ;; If we have a new initarg, check for it. (when init @@ -983,19 +707,19 @@ if default value is nil." (let ((value (eieio-default-eval-maybe d))) (if (not (member a (eieio--class-class-allocation-a newc))) (progn - (eieio-perform-slot-validation-for-default a type value skipnil) + (eieio--perform-slot-validation-for-default a type value skipnil) ;; Here we have found a :class version of a slot. This ;; requires a very different approach. - (setf (eieio--class-class-allocation-a newc) (cons a (eieio--class-class-allocation-a newc))) - (setf (eieio--class-class-allocation-doc newc) (cons doc (eieio--class-class-allocation-doc newc))) - (setf (eieio--class-class-allocation-type newc) (cons type (eieio--class-class-allocation-type newc))) - (setf (eieio--class-class-allocation-custom newc) (cons cust (eieio--class-class-allocation-custom newc))) - (setf (eieio--class-class-allocation-custom-label newc) (cons label (eieio--class-class-allocation-custom-label newc))) - (setf (eieio--class-class-allocation-custom-group newc) (cons custg (eieio--class-class-allocation-custom-group newc))) - (setf (eieio--class-class-allocation-protection newc) (cons prot (eieio--class-class-allocation-protection newc))) + (push a (eieio--class-class-allocation-a newc)) + (push doc (eieio--class-class-allocation-doc newc)) + (push type (eieio--class-class-allocation-type newc)) + (push cust (eieio--class-class-allocation-custom newc)) + (push label (eieio--class-class-allocation-custom-label newc)) + (push custg (eieio--class-class-allocation-custom-group newc)) + (push prot (eieio--class-class-allocation-protection newc)) ;; Default value is stored in the 'values section, since new objects ;; can't initialize from this element. - (setf (eieio--class-class-allocation-values newc) (cons value (eieio--class-class-allocation-values newc)))) + (push value (eieio--class-class-allocation-values newc))) (when defaultoverride ;; There is a match, and we must override the old value. (let* ((ca (eieio--class-class-allocation-a newc)) @@ -1020,7 +744,7 @@ if default value is nil." ;; is to change the default, so allow unbound in. ;; If we have a repeat, only update the value... - (eieio-perform-slot-validation-for-default a tp value skipnil) + (eieio--perform-slot-validation-for-default a tp value skipnil) (setcar dp value)) ;; PLN Tue Jun 26 11:57:06 2007 : The protection is @@ -1065,289 +789,85 @@ 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." - (let ((ps (eieio--class-parent newc)) - (sn (class-option-assoc (eieio--class-options newc) - ':allow-nil-initform))) - (while ps + (let ((sn (eieio--class-option-assoc (eieio--class-options newc) + :allow-nil-initform))) + (dolist (pcv (eieio--class-parent newc)) ;; First, duplicate all the slots of the parent. - (let ((pcv (class-v (car ps)))) - (let ((pa (eieio--class-public-a pcv)) - (pd (eieio--class-public-d pcv)) - (pdoc (eieio--class-public-doc pcv)) - (ptype (eieio--class-public-type pcv)) - (pcust (eieio--class-public-custom pcv)) - (plabel (eieio--class-public-custom-label pcv)) - (pcustg (eieio--class-public-custom-group pcv)) - (printer (eieio--class-public-printer pcv)) - (pprot (eieio--class-protection pcv)) - (pinit (eieio--class-initarg-tuples pcv)) - (i 0)) - (while pa - (eieio-add-new-slot newc - (car pa) (car pd) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) (car-safe (car pinit)) nil nil sn) - ;; Increment each value. - (setq pa (cdr pa) - pd (cdr pd) - pdoc (cdr pdoc) - i (1+ i) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - pinit (cdr pinit)) - )) ;; while/let - ;; Now duplicate all the class alloc slots. - (let ((pa (eieio--class-class-allocation-a pcv)) - (pdoc (eieio--class-class-allocation-doc pcv)) - (ptype (eieio--class-class-allocation-type pcv)) - (pcust (eieio--class-class-allocation-custom pcv)) - (plabel (eieio--class-class-allocation-custom-label pcv)) - (pcustg (eieio--class-class-allocation-custom-group pcv)) - (printer (eieio--class-class-allocation-printer pcv)) - (pprot (eieio--class-class-allocation-protection pcv)) - (pval (eieio--class-class-allocation-values pcv)) - (i 0)) - (while pa - (eieio-add-new-slot newc - (car pa) (aref pval i) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) nil ':class sn) - ;; Increment each value. - (setq pa (cdr pa) - pdoc (cdr pdoc) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - i (1+ i)) - ))) ;; while/let - ;; Loop over each parent class - (setq ps (cdr ps))) - )) + (let ((pa (eieio--class-public-a pcv)) + (pd (eieio--class-public-d pcv)) + (pdoc (eieio--class-public-doc pcv)) + (ptype (eieio--class-public-type pcv)) + (pcust (eieio--class-public-custom pcv)) + (plabel (eieio--class-public-custom-label pcv)) + (pcustg (eieio--class-public-custom-group pcv)) + (printer (eieio--class-public-printer pcv)) + (pprot (eieio--class-protection pcv)) + (pinit (eieio--class-initarg-tuples pcv)) + (i 0)) + (while pa + (eieio--add-new-slot newc + (car pa) (car pd) (car pdoc) (aref ptype i) + (car pcust) (car plabel) (car pcustg) + (car printer) + (car pprot) (car-safe (car pinit)) nil nil sn) + ;; Increment each value. + (setq pa (cdr pa) + pd (cdr pd) + pdoc (cdr pdoc) + i (1+ i) + pcust (cdr pcust) + plabel (cdr plabel) + pcustg (cdr pcustg) + printer (cdr printer) + pprot (cdr pprot) + pinit (cdr pinit)) + )) ;; while/let + ;; Now duplicate all the class alloc slots. + (let ((pa (eieio--class-class-allocation-a pcv)) + (pdoc (eieio--class-class-allocation-doc pcv)) + (ptype (eieio--class-class-allocation-type pcv)) + (pcust (eieio--class-class-allocation-custom pcv)) + (plabel (eieio--class-class-allocation-custom-label pcv)) + (pcustg (eieio--class-class-allocation-custom-group pcv)) + (printer (eieio--class-class-allocation-printer pcv)) + (pprot (eieio--class-class-allocation-protection pcv)) + (pval (eieio--class-class-allocation-values pcv)) + (i 0)) + (while pa + (eieio--add-new-slot newc + (car pa) (aref pval i) (car pdoc) (aref ptype i) + (car pcust) (car plabel) (car pcustg) + (car printer) + (car pprot) nil :class sn) + ;; Increment each value. + (setq pa (cdr pa) + pdoc (cdr pdoc) + pcust (cdr pcust) + plabel (cdr plabel) + pcustg (cdr pcustg) + printer (cdr printer) + pprot (cdr pprot) + i (1+ i)) + ))))) -;;; CLOS methods and generics -;; - -(defun eieio--defgeneric-init-form (method doc-string) - "Form to use for the initial definition of a generic." - (cond - ((or (not (fboundp method)) - (eq 'autoload (car-safe (symbol-function method)))) - ;; Make sure the method tables are installed. - (eieiomt-install method) - ;; Construct the actual body of this function. - (eieio-defgeneric-form method doc-string)) - ((generic-p method) (symbol-function method)) ;Leave it as-is. - (t (error "You cannot create a generic/method over an existing symbol: %s" - method)))) - -(defun eieio-defgeneric-form (method doc-string) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD." - `(lambda (&rest local-args) - ,doc-string - (eieio-generic-call (quote ,method) local-args))) - -(defsubst eieio-defgeneric-reset-generic-form (method) - "Setup METHOD to call the generic form." - (let ((doc-string (documentation method))) - (fset method (eieio-defgeneric-form method doc-string)))) - -(defun eieio-defgeneric-form-primary-only (method doc-string) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD." - `(lambda (&rest local-args) - ,doc-string - (eieio-generic-call-primary-only (quote ,method) local-args))) - -(defsubst eieio-defgeneric-reset-generic-form-primary-only (method) - "Setup METHOD to call the generic form." - (let ((doc-string (documentation method))) - (fset method (eieio-defgeneric-form-primary-only method doc-string)))) - -(defun eieio-defgeneric-form-primary-only-one (method doc-string - class - impl - ) - "The lambda form that would be used as the function defined on METHOD. -All methods should call the same EIEIO function for dispatch. -DOC-STRING is the documentation attached to METHOD. -CLASS is the class symbol needed for private method access. -IMPL is the symbol holding the method implementation." - ;; NOTE: I tried out byte compiling this little fcn. Turns out it - ;; is faster to execute this for not byte-compiled. ie, install this, - ;; then measure calls going through here. I wonder why. - (require 'bytecomp) - (let ((byte-compile-warnings nil)) - (byte-compile - `(lambda (&rest local-args) - ,doc-string - ;; This is a cool cheat. Usually we need to look up in the - ;; method table to find out if there is a method or not. We can - ;; instead make that determination at load time when there is - ;; only one method. If the first arg is not a child of the class - ;; of that one implementation, then clearly, there is no method def. - (if (not (eieio-object-p (car local-args))) - ;; Not an object. Just signal. - (signal 'no-method-definition - (list ',method local-args)) - - ;; We do have an object. Make sure it is the right type. - (if ,(if (eq class eieio-default-superclass) - nil ; default superclass means just an obj. Already asked. - `(not (child-of-class-p (eieio--object-class (car local-args)) - ',class))) - - ;; If not the right kind of object, call no applicable - (apply 'no-applicable-method (car local-args) - ',method local-args) - - ;; It is ok, do the call. - ;; Fill in inter-call variables then evaluate the method. - (let ((eieio-generic-call-next-method-list nil) - (eieio-generic-call-key method-primary) - (eieio-generic-call-methodname ',method) - (eieio-generic-call-arglst local-args) - ) - (eieio--with-scoped-class ',class - ,(if (< emacs-major-version 24) - `(apply ,(list 'quote impl) local-args) - `(apply #',impl local-args))) - ;(,impl local-args) - ))))))) - -(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) - "Setup METHOD to call the generic form." - (let* ((doc-string (documentation method)) - (M (get method 'eieio-method-tree)) - (entry (car (aref M method-primary))) - ) - (fset method (eieio-defgeneric-form-primary-only-one - method doc-string - (car entry) - (cdr entry) - )))) - -(defun eieio-unbind-method-implementations (method) - "Make the generic method METHOD have no implementations. -It will leave the original generic function in place, -but remove reference to all implementations of METHOD." - (put method 'eieio-method-tree nil) - (put method 'eieio-method-obarray nil)) - -(defun eieio--defmethod (method kind argclass code) - "Work part of the `defmethod' macro defining METHOD with ARGS." - (let ((key - ;; Find optional keys. - (cond ((memq kind '(:BEFORE :before)) method-before) - ((memq kind '(:AFTER :after)) method-after) - ((memq kind '(:STATIC :static)) method-static) - ((memq kind '(:PRIMARY :primary nil)) method-primary) - ;; Primary key. - ;; (t method-primary) - (t (error "Unknown method kind %S" kind))))) - ;; Make sure there is a generic (when called from defclass). - (eieio--defalias - method (eieio--defgeneric-init-form - method (or (documentation code) - (format "Generically created method `%s'." method)))) - ;; Create symbol for property to bind to. If the first arg is of - ;; the form (varname vartype) and `vartype' is a class, then - ;; that class will be the type symbol. If not, then it will fall - ;; under the type `primary' which is a non-specific calling of the - ;; function. - (if argclass - (if (not (class-p argclass)) - (error "Unknown class type %s in method parameters" - argclass)) - ;; Generics are higher. - (setq key (eieio-specialized-key-to-generic-key key))) - ;; Put this lambda into the symbol so we can find it. - (eieiomt-add method code key argclass) - ) - - (when eieio-optimize-primary-methods-flag - ;; Optimizing step: - ;; - ;; If this method, after this setup, only has primary methods, then - ;; we can setup the generic that way. - (if (generic-primary-only-p method) - ;; If there is only one primary method, then we can go one more - ;; optimization step. - (if (generic-primary-only-one-p method) - (eieio-defgeneric-reset-generic-form-primary-only-one method) - (eieio-defgeneric-reset-generic-form-primary-only method)) - (eieio-defgeneric-reset-generic-form method))) - - method) - ;;; Slot type validation ;; This is a hideous hack for replacing `typep' from cl-macs, to avoid ;; requiring the CL library at run-time. It can be eliminated if/when ;; `typep' is merged into Emacs core. -(defun eieio--typep (val type) - (if (symbolp type) - (cond ((get type 'cl-deftype-handler) - (eieio--typep val (funcall (get type 'cl-deftype-handler)))) - ((eq type t) t) - ((eq type 'null) (null val)) - ((eq type 'atom) (atom val)) - ((eq type 'float) (and (numberp val) (not (integerp val)))) - ((eq type 'real) (numberp val)) - ((eq type 'fixnum) (integerp val)) - ((memq type '(character string-char)) (characterp val)) - (t - (let* ((name (symbol-name type)) - (namep (intern (concat name "p")))) - (if (fboundp namep) - (funcall `(lambda () (,namep val))) - (funcall `(lambda () - (,(intern (concat name "-p")) val))))))) - (cond ((get (car type) 'cl-deftype-handler) - (eieio--typep val (apply (get (car type) 'cl-deftype-handler) - (cdr type)))) - ((memq (car type) '(integer float real number)) - (and (eieio--typep val (car type)) - (or (memq (cadr type) '(* nil)) - (if (consp (cadr type)) - (> val (car (cadr type))) - (>= val (cadr type)))) - (or (memq (caddr type) '(* nil)) - (if (consp (car (cddr type))) - (< val (caar (cddr type))) - (<= val (car (cddr type))))))) - ((memq (car type) '(and or not)) - (eval (cons (car type) - (mapcar (lambda (x) - `(eieio--typep (quote ,val) (quote ,x))) - (cdr type))))) - ((memq (car type) '(member member*)) - (memql val (cdr type))) - ((eq (car type) 'satisfies) - (funcall `(lambda () (,(cadr type) val)))) - (t (error "Bad type spec: %s" type))))) - -(defun eieio-perform-slot-validation (spec value) + +(defun eieio--perform-slot-validation (spec value) "Return non-nil if SPEC does not match VALUE." (or (eq spec t) ; t always passes (eq value eieio-unbound) ; unbound always passes - (eieio--typep value spec))) + (cl-typep value spec))) -(defun eieio-validate-slot-value (class slot-idx value slot) +(defun eieio--validate-slot-value (class slot-idx value slot) "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. Checks the :type specifier. SLOT is the slot that is being checked, and is only used when throwing @@ -1355,22 +875,24 @@ an error." (if eieio-skip-typecheck nil ;; Trim off object IDX junk added in for the object index. - (setq slot-idx (- slot-idx 3)) - (let ((st (aref (eieio--class-public-type (class-v class)) slot-idx))) - (if (not (eieio-perform-slot-validation st value)) - (signal 'invalid-slot-type (list class slot st value)))))) + (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) + (let ((st (aref (eieio--class-public-type class) slot-idx))) + (if (not (eieio--perform-slot-validation st value)) + (signal 'invalid-slot-type + (list (eieio--class-symbol class) slot st value)))))) -(defun eieio-validate-class-slot-value (class slot-idx value slot) +(defun eieio--validate-class-slot-value (class slot-idx value slot) "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. Checks the :type specifier. SLOT is the slot that is being checked, and is only used when throwing an error." (if eieio-skip-typecheck nil - (let ((st (aref (eieio--class-class-allocation-type (class-v class)) + (let ((st (aref (eieio--class-class-allocation-type class) slot-idx))) - (if (not (eieio-perform-slot-validation st value)) - (signal 'invalid-slot-type (list class slot st value)))))) + (if (not (eieio--perform-slot-validation st value)) + (signal 'invalid-slot-type + (list (eieio--class-symbol class) slot st value)))))) (defun eieio-barf-if-slot-unbound (value instance slotname fn) "Throw a signal if VALUE is a representation of an UNBOUND slot. @@ -1378,7 +900,7 @@ INSTANCE is the object being referenced. SLOTNAME is the offending slot. If the slot is ok, return VALUE. Argument FN is the function calling this verifier." (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) - (slot-unbound instance (eieio--object-class instance) slotname fn) + (slot-unbound instance (eieio--object-class-name instance) slotname fn) value)) @@ -1389,14 +911,17 @@ Argument FN is the function calling this verifier." (eieio--check-type (or eieio-object-p class-p) obj) (eieio--check-type symbolp slot) (if (class-p obj) (eieio-class-un-autoload obj)) - (let* ((class (if (class-p obj) obj (eieio--object-class obj))) - (c (eieio-slot-name-index class obj slot))) + (let* ((class (cond ((symbolp obj) + (error "eieio-oref called on a class!") + (eieio--class-v obj)) + (t (eieio--object-class-object obj)))) + (c (eieio--slot-name-index class obj slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. ;; Let's check that info out. - (if (setq c (eieio-class-slot-name-index class slot)) + (if (setq c (eieio--class-slot-name-index class slot)) ;; Oref that slot. - (aref (eieio--class-class-allocation-values (class-v class)) c) + (aref (eieio--class-class-allocation-values class) c) ;; The slot-missing method is a cool way of allowing an object author ;; to intercept missing slot definitions. Since it is also the LAST ;; thing called in this fn, its return value would be retrieved. @@ -1412,26 +937,30 @@ Argument FN is the function calling this verifier." Fills in OBJ's SLOT with its default value." (eieio--check-type (or eieio-object-p class-p) obj) (eieio--check-type symbolp slot) - (let* ((cl (if (eieio-object-p obj) (eieio--object-class obj) obj)) - (c (eieio-slot-name-index cl obj slot))) + (let* ((cl (cond ((symbolp obj) (eieio--class-v obj)) + (t (eieio--object-class-object obj)))) + (c (eieio--slot-name-index cl obj slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. ;; Let's check that info out. (if (setq c - (eieio-class-slot-name-index cl slot)) + (eieio--class-slot-name-index cl slot)) ;; Oref that slot. - (aref (eieio--class-class-allocation-values (class-v cl)) + (aref (eieio--class-class-allocation-values cl) c) (slot-missing obj slot 'oref-default) ;;(signal 'invalid-slot-name (list (class-name cl) slot)) ) (eieio-barf-if-slot-unbound - (let ((val (nth (- c 3) (eieio--class-public-d (class-v cl))))) + (let ((val (nth (- c (eval-when-compile eieio--object-num-slots)) + (eieio--class-public-d cl)))) (eieio-default-eval-maybe val)) - obj cl 'oref-default)))) + obj (eieio--class-symbol cl) 'oref-default)))) (defun eieio-default-eval-maybe (val) "Check VAL, and return what `oref-default' would provide." + ;; FIXME: What the hell is this supposed to do? Shouldn't it evaluate + ;; variables as well? Why not just always call `eval'? (cond ;; Is it a function call? If so, evaluate it. ((eieio-eval-default-p val) @@ -1447,69 +976,56 @@ Fills in OBJ's SLOT with its default value." Fills in OBJ's SLOT with VALUE." (eieio--check-type eieio-object-p obj) (eieio--check-type symbolp slot) - (let ((c (eieio-slot-name-index (eieio--object-class obj) obj slot))) + (let* ((class (eieio--object-class-object obj)) + (c (eieio--slot-name-index class obj slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. ;; Let's check that info out. (if (setq c - (eieio-class-slot-name-index (eieio--object-class obj) slot)) + (eieio--class-slot-name-index class slot)) ;; Oset that slot. (progn - (eieio-validate-class-slot-value (eieio--object-class obj) c value slot) - (aset (eieio--class-class-allocation-values (class-v (eieio--object-class obj))) + (eieio--validate-class-slot-value class c value slot) + (aset (eieio--class-class-allocation-values class) c value)) ;; See oref for comment on `slot-missing' (slot-missing obj slot 'oset value) ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) ) - (eieio-validate-slot-value (eieio--object-class obj) c value slot) + (eieio--validate-slot-value class c value slot) (aset obj c value)))) (defun eieio-oset-default (class slot value) "Do the work for the macro `oset-default'. Fills in the default value in CLASS' in SLOT with VALUE." - (eieio--check-type class-p class) + (setq class (eieio--class-object class)) + (eieio--check-type eieio--class-p class) (eieio--check-type symbolp slot) - (eieio--with-scoped-class class - (let* ((c (eieio-slot-name-index class nil slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c (eieio-class-slot-name-index class slot)) - (progn - ;; Oref that slot. - (eieio-validate-class-slot-value class c value slot) - (aset (eieio--class-class-allocation-values (class-v class)) c - value)) - (signal 'invalid-slot-name (list (eieio-class-name class) slot))) - (eieio-validate-slot-value class c value slot) - ;; Set this into the storage for defaults. - (setcar (nthcdr (- c 3) (eieio--class-public-d (class-v class))) - value) - ;; Take the value, and put it into our cache object. - (eieio-oset (eieio--class-default-object-cache (class-v class)) - slot value) - )))) + (let* ((c (eieio--slot-name-index class nil slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c (eieio--class-slot-name-index class slot)) + (progn + ;; Oref that slot. + (eieio--validate-class-slot-value class c value slot) + (aset (eieio--class-class-allocation-values class) c + value)) + (signal 'invalid-slot-name (list (eieio--class-symbol class) slot))) + (eieio--validate-slot-value class c value slot) + ;; Set this into the storage for defaults. + (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots)) + (eieio--class-public-d class)) + value) + ;; Take the value, and put it into our cache object. + (eieio-oset (eieio--class-default-object-cache class) + slot value) + ))) ;;; EIEIO internal search functions ;; -(defun eieio-slot-originating-class-p (start-class slot) - "Return non-nil if START-CLASS is the first class to define SLOT. -This is for testing if the class currently in scope is the class that defines SLOT -so that we can protect private slots." - (let ((par (eieio-class-parents-fast start-class)) - (ret t)) - (if (not par) - t - (while (and par ret) - (if (intern-soft (symbol-name slot) - (eieio--class-symbol-obarray (class-v (car par)))) - (setq ret nil)) - (setq par (cdr par))) - ret))) - -(defun eieio-slot-name-index (class obj slot) +(defun eieio--slot-name-index (class obj slot) "In CLASS for OBJ find the index of the named SLOT. The slot is a symbol which is installed in CLASS by the `defclass' call. OBJ can be nil, but if it is an object, and the slot in question @@ -1518,36 +1034,21 @@ scoped class. If SLOT is the value created with :initarg instead, reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call - (let* ((fsym (intern-soft (symbol-name slot) - (eieio--class-symbol-obarray (class-v class)))) - (fsi (if (symbolp fsym) (symbol-value fsym) nil))) + (let* ((fsym (gethash slot (eieio--class-symbol-hashtable class))) + (fsi (car fsym))) (if (integerp fsi) - (cond - ((not (get fsym 'protection)) - (+ 3 fsi)) - ((and (eq (get fsym 'protection) 'protected) - (eieio--scoped-class) - (or (child-of-class-p class (eieio--scoped-class)) - (and (eieio-object-p obj) - (child-of-class-p class (eieio--object-class obj))))) - (+ 3 fsi)) - ((and (eq (get fsym 'protection) 'private) - (or (and (eieio--scoped-class) - (eieio-slot-originating-class-p (eieio--scoped-class) slot)) - eieio-initializing-object)) - (+ 3 fsi)) - (t nil)) - (let ((fn (eieio-initarg-to-attribute class slot))) - (if fn (eieio-slot-name-index class obj fn) nil))))) - -(defun eieio-class-slot-name-index (class slot) + (+ (eval-when-compile eieio--object-num-slots) fsi) + (let ((fn (eieio--initarg-to-attribute class slot))) + (if fn (eieio--slot-name-index class obj fn) nil))))) + +(defun eieio--class-slot-name-index (class slot) "In CLASS find the index of the named SLOT. The slot is a symbol which is installed in CLASS by the `defclass' call. If SLOT is the value created with :initarg instead, reverse-lookup that name, and recurse with the associated slot value." ;; This will happen less often, and with fewer slots. Do this the ;; storage cheap way. - (let* ((a (eieio--class-class-allocation-a (class-v class))) + (let* ((a (eieio--class-class-allocation-a class)) (l1 (length a)) (af (memq slot a)) (l2 (length af))) @@ -1564,36 +1065,26 @@ reverse-lookup that name, and recurse with the associated slot value." If SET-ALL is non-nil, then when a default is nil, that value is reset. If SET-ALL is nil, the slots are only reset if the default is not nil." - (eieio--with-scoped-class (eieio--object-class obj) - (let ((eieio-initializing-object t) - (pub (eieio--class-public-a (class-v (eieio--object-class obj))))) - (while pub - (let ((df (eieio-oref-default obj (car pub)))) - (if (or df set-all) - (eieio-oset obj (car pub) df))) - (setq pub (cdr pub)))))) - -(defun eieio-initarg-to-attribute (class initarg) + (let ((pub (eieio--class-public-a (eieio--object-class-object obj)))) + (while pub + (let ((df (eieio-oref-default obj (car pub)))) + (if (or df set-all) + (eieio-oset obj (car pub) df))) + (setq pub (cdr pub))))) + +(defun eieio--initarg-to-attribute (class initarg) "For CLASS, convert INITARG to the actual attribute name. If there is no translation, pass it in directly (so we can cheat if need be... May remove that later...)" - (let ((tuple (assoc initarg (eieio--class-initarg-tuples (class-v class))))) + (let ((tuple (assoc initarg (eieio--class-initarg-tuples class)))) (if tuple (cdr tuple) nil))) -(defun eieio-attribute-to-initarg (class attribute) - "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. -This is usually a symbol that starts with `:'." - (let ((tuple (rassoc attribute (eieio--class-initarg-tuples (class-v class))))) - (if tuple - (car tuple) - nil))) - ;;; ;; Method Invocation order: C3 -(defun eieio-c3-candidate (class remaining-inputs) - "Return CLASS if it can go in the result now, otherwise nil" +(defun eieio--c3-candidate (class remaining-inputs) + "Return CLASS if it can go in the result now, otherwise nil." ;; Ensure CLASS is not in any position but the first in any of the ;; element lists of REMAINING-INPUTS. (and (not (let ((found nil)) @@ -1603,7 +1094,7 @@ This is usually a symbol that starts with `:'." found)) class)) -(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) +(defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs) "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. If a consistent order does not exist, signal an error." (if (let ((tail remaining-inputs) @@ -1622,41 +1113,38 @@ If a consistent order does not exist, signal an error." (next (progn (while (and tail (not found)) (setq found (and (car tail) - (eieio-c3-candidate (caar tail) - remaining-inputs)) + (eieio--c3-candidate (caar tail) + remaining-inputs)) tail (cdr tail))) found))) (if next ;; The graph is consistent so far, add NEXT to result and ;; merge input lists, dropping NEXT from their heads where ;; applicable. - (eieio-c3-merge-lists + (eieio--c3-merge-lists (cons next reversed-partial-result) - (mapcar (lambda (l) (if (eq (first l) next) (rest l) l)) + (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l)) remaining-inputs)) ;; The graph is inconsistent, give up (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) -(defun eieio-class-precedence-c3 (class) +(defun eieio--class-precedence-c3 (class) "Return all parents of CLASS in c3 order." - (let ((parents (eieio-class-parents-fast class))) - (eieio-c3-merge-lists + (let ((parents (eieio--class-parent (eieio--class-v class)))) + (eieio--c3-merge-lists (list class) (append (or - (mapcar - (lambda (x) - (eieio-class-precedence-c3 x)) - parents) - '((eieio-default-superclass))) + (mapcar #'eieio--class-precedence-c3 parents) + `((,eieio-default-superclass))) (list parents)))) ) ;;; ;; Method Invocation Order: Depth First -(defun eieio-class-precedence-dfs (class) +(defun eieio--class-precedence-dfs (class) "Return all parents of CLASS in depth-first order." - (let* ((parents (eieio-class-parents-fast class)) + (let* ((parents (eieio--class-parent class)) (classes (copy-sequence (apply #'append (list class) @@ -1664,9 +1152,9 @@ If a consistent order does not exist, signal an error." (mapcar (lambda (parent) (cons parent - (eieio-class-precedence-dfs parent))) + (eieio--class-precedence-dfs parent))) parents) - '((eieio-default-superclass)))))) + `((,eieio-default-superclass)))))) (tail classes)) ;; Remove duplicates. (while tail @@ -1676,588 +1164,190 @@ If a consistent order does not exist, signal an error." ;;; ;; Method Invocation Order: Breadth First -(defun eieio-class-precedence-bfs (class) +(defun eieio--class-precedence-bfs (class) "Return all parents of CLASS in breadth-first order." - (let ((result) - (queue (or (eieio-class-parents-fast class) - '(eieio-default-superclass)))) + (let* ((result) + (queue (or (eieio--class-parent class) + `(,eieio-default-superclass)))) (while queue (let ((head (pop queue))) (unless (member head result) (push head result) - (unless (eq head 'eieio-default-superclass) - (setq queue (append queue (or (eieio-class-parents-fast head) - '(eieio-default-superclass)))))))) + (unless (eq head eieio-default-superclass) + (setq queue (append queue (or (eieio--class-parent head) + `(,eieio-default-superclass)))))))) (cons class (nreverse result))) ) ;;; ;; Method Invocation Order -(defun eieio-class-precedence-list (class) +(defun eieio--class-precedence-list (class) "Return (transitively closed) list of parents of CLASS. The order, in which the parents are returned depends on the method invocation orders of the involved classes." - (if (or (null class) (eq class 'eieio-default-superclass)) + (if (or (null class) (eq class eieio-default-superclass)) nil - (case (class-method-invocation-order class) + (unless (eieio--class-default-object-cache class) + (eieio-class-un-autoload (eieio--class-symbol class))) + (cl-case (eieio--class-method-invocation-order class) (:depth-first - (eieio-class-precedence-dfs class)) + (eieio--class-precedence-dfs class)) (:breadth-first - (eieio-class-precedence-bfs class)) + (eieio--class-precedence-bfs class)) (:c3 - (eieio-class-precedence-c3 class)))) + (eieio--class-precedence-c3 class)))) ) (define-obsolete-function-alias - 'class-precedence-list 'eieio-class-precedence-list "24.4") + 'class-precedence-list 'eieio--class-precedence-list "24.4") -;;; CLOS generics internal function handling +;;; Here are some special types of errors ;; -(defvar eieio-generic-call-methodname nil - "When using `call-next-method', provides a context on how to do it.") -(defvar eieio-generic-call-arglst nil - "When using `call-next-method', provides a context for parameters.") -(defvar eieio-generic-call-key nil - "When using `call-next-method', provides a context for the current key. -Keys are a number representing :before, :primary, and :after methods.") -(defvar eieio-generic-call-next-method-list nil - "When executing a PRIMARY or STATIC method, track the 'next-method'. -During executions, the list is first generated, then as each next method -is called, the next method is popped off the stack.") - -(define-obsolete-variable-alias 'eieio-pre-method-execution-hooks - 'eieio-pre-method-execution-functions "24.3") -(defvar eieio-pre-method-execution-functions nil - "Abnormal hook run just before an EIEIO method is executed. -The hook function must accept one argument, the list of forms -about to be executed.") - -(defun eieio-generic-call (method args) - "Call METHOD with ARGS. -ARGS provides the context on which implementation to use. -This should only be called from a generic function." - ;; We must expand our arguments first as they are always - ;; passed in as quoted symbols - (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) - (eieio-generic-call-methodname method) - (eieio-generic-call-arglst args) - (firstarg nil) - (primarymethodlist nil)) - ;; get a copy - (setq newargs args - firstarg (car newargs)) - ;; Is the class passed in autoloaded? - ;; Since class names are also constructors, they can be autoloaded - ;; via the autoload command. Check for this, and load them in. - ;; It is ok if it doesn't turn out to be a class. Probably want that - ;; function loaded anyway. - (if (and (symbolp firstarg) - (fboundp firstarg) - (listp (symbol-function firstarg)) - (eq 'autoload (car (symbol-function firstarg)))) - (load (nth 1 (symbol-function firstarg)))) - ;; Determine the class to use. - (cond ((eieio-object-p firstarg) - (setq mclass (eieio--object-class firstarg))) - ((class-p firstarg) - (setq mclass firstarg)) - ) - ;; Make sure the class is a valid class - ;; mclass can be nil (meaning a generic for should be used. - ;; mclass cannot have a value that is not a class, however. - (when (and (not (null mclass)) (not (class-p mclass))) - (error "Cannot dispatch method %S on class %S" - method mclass) - ) - ;; Now create a list in reverse order of all the calls we have - ;; make in order to successfully do this right. Rules: - ;; 1) Only call generics if scoped-class is not defined - ;; This prevents multiple calls in the case of recursion - ;; 2) Only call static if this is a static method. - ;; 3) Only call specifics if the definition allows for them. - ;; 4) Call in order based on :before, :primary, and :after - (when (eieio-object-p firstarg) - ;; Non-static calls do all this stuff. - - ;; :after methods - (setq tlambdas - (if mclass - (eieiomt-method-list method method-after mclass) - (list (eieio-generic-form method method-after nil))) - ;;(or (and mclass (eieio-generic-form method method-after mclass)) - ;; (eieio-generic-form method method-after nil)) - ) - (setq lambdas (append tlambdas lambdas) - keys (append (make-list (length tlambdas) method-after) keys)) - - ;; :primary methods - (setq tlambdas - (or (and mclass (eieio-generic-form method method-primary mclass)) - (eieio-generic-form method method-primary nil))) - (when tlambdas - (setq lambdas (cons tlambdas lambdas) - keys (cons method-primary keys) - primarymethodlist - (eieiomt-method-list method method-primary mclass))) - - ;; :before methods - (setq tlambdas - (if mclass - (eieiomt-method-list method method-before mclass) - (list (eieio-generic-form method method-before nil))) - ;;(or (and mclass (eieio-generic-form method method-before mclass)) - ;; (eieio-generic-form method method-before nil)) - ) - (setq lambdas (append tlambdas lambdas) - keys (append (make-list (length tlambdas) method-before) keys)) - ) - - (if mclass - ;; For the case of a class, - ;; if there were no methods found, then there could be :static methods. - (when (not lambdas) - (setq tlambdas - (eieio-generic-form method method-static mclass)) - (setq lambdas (cons tlambdas lambdas) - keys (cons method-static keys) - primarymethodlist ;; Re-use even with bad name here - (eieiomt-method-list method method-static mclass))) - ;; For the case of no class (ie - mclass == nil) then there may - ;; be a primary method. - (setq tlambdas - (eieio-generic-form method method-primary nil)) - (when tlambdas - (setq lambdas (cons tlambdas lambdas) - keys (cons method-primary keys) - primarymethodlist - (eieiomt-method-list method method-primary nil))) - ) - - (run-hook-with-args 'eieio-pre-method-execution-functions - primarymethodlist) - - ;; Now loop through all occurrences forms which we must execute - ;; (which are happily sorted now) and execute them all! - (let ((rval nil) (lastval nil) (rvalever nil) (found nil)) - (while lambdas - (if (car lambdas) - (eieio--with-scoped-class (cdr (car lambdas)) - (let* ((eieio-generic-call-key (car keys)) - (has-return-val - (or (= eieio-generic-call-key method-primary) - (= eieio-generic-call-key method-static))) - (eieio-generic-call-next-method-list - ;; Use the cdr, as the first element is the fcn - ;; we are calling right now. - (when has-return-val (cdr primarymethodlist))) - ) - (setq found t) - ;;(setq rval (apply (car (car lambdas)) newargs)) - (setq lastval (apply (car (car lambdas)) newargs)) - (when has-return-val - (setq rval lastval - rvalever t)) - ))) - (setq lambdas (cdr lambdas) - keys (cdr keys))) - (if (not found) - (if (eieio-object-p (car args)) - (setq rval (apply 'no-applicable-method (car args) method args) - rvalever t) - (signal - 'no-method-definition - (list method args)))) - ;; Right Here... it could be that lastval is returned when - ;; rvalever is nil. Is that right? - rval))) - -(defun eieio-generic-call-primary-only (method args) - "Call METHOD with ARGS for methods with only :PRIMARY implementations. -ARGS provides the context on which implementation to use. -This should only be called from a generic function. - -This method is like `eieio-generic-call', but only -implementations in the :PRIMARY slot are queried. After many -years of use, it appears that over 90% of methods in use -have :PRIMARY implementations only. We can therefore optimize -for this common case to improve performance." - ;; We must expand our arguments first as they are always - ;; passed in as quoted symbols - (let ((newargs nil) (mclass nil) (lambdas nil) - (eieio-generic-call-methodname method) - (eieio-generic-call-arglst args) - (firstarg nil) - (primarymethodlist nil) - ) - ;; get a copy - (setq newargs args - firstarg (car newargs)) - - ;; Determine the class to use. - (cond ((eieio-object-p firstarg) - (setq mclass (eieio--object-class firstarg))) - ((not firstarg) - (error "Method %s called on nil" method)) - ((not (eieio-object-p firstarg)) - (error "Primary-only method %s called on something not an object" method)) - (t - (error "EIEIO Error: Improperly classified method %s as primary only" - method) - )) - ;; Make sure the class is a valid class - ;; mclass can be nil (meaning a generic for should be used. - ;; mclass cannot have a value that is not a class, however. - (when (null mclass) - (error "Cannot dispatch method %S on class %S" method mclass) - ) - - ;; :primary methods - (setq lambdas (eieio-generic-form method method-primary mclass)) - (setq primarymethodlist ;; Re-use even with bad name here - (eieiomt-method-list method method-primary mclass)) - - ;; Now loop through all occurrences forms which we must execute - ;; (which are happily sorted now) and execute them all! - (eieio--with-scoped-class (cdr lambdas) - (let* ((rval nil) (lastval nil) (rvalever nil) - (eieio-generic-call-key method-primary) - ;; Use the cdr, as the first element is the fcn - ;; we are calling right now. - (eieio-generic-call-next-method-list (cdr primarymethodlist)) - ) +(define-error 'invalid-slot-name "Invalid slot name") +(define-error 'invalid-slot-type "Invalid slot type") +(define-error 'unbound-slot "Unbound slot") +(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy") + +;;; Hooking into cl-generic. + +(require 'cl-generic) + +;;;; General support to dispatch based on the type of the argument. + +(add-function :before-until cl-generic-tagcode-function + #'eieio--generic-tagcode) +(defun eieio--generic-tagcode (type name) + ;; CLHS says: + ;; A class must be defined before it can be used as a parameter + ;; specializer in a defmethod form. + ;; So we can ignore types that are not known to denote classes. + (and (class-p type) + ;; Prefer (aref ,name 0) over (eieio--class-tag ,name) so that + ;; the tagcode is identical to the tagcode used for cl-struct. + `(50 . (and (vectorp ,name) (aref ,name 0))))) + +(add-function :before-until cl-generic-tag-types-function + #'eieio--generic-tag-types) +(defun eieio--generic-tag-types (tag) + (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) + (mapcar #'eieio--class-symbol + (eieio--class-precedence-list (symbol-value tag))))) + +;;;; Dispatch for arguments which are classes. + +;; Since EIEIO does not support metaclasses, users can't easily use the +;; "dispatch on argument type" for class arguments. That's why EIEIO's +;; `defmethod' added the :static qualifier. For cl-generic, such a qualifier +;; would not make much sense (e.g. to which argument should it apply?). +;; Instead, we add a new "subclass" specializer. + +(add-function :before-until cl-generic-tagcode-function + #'eieio--generic-subclass-tagcode) +(defun eieio--generic-subclass-tagcode (type name) + (when (eq 'subclass (car-safe type)) + `(60 . (and (symbolp ,name) (eieio--class-v ,name))))) + +(add-function :before-until cl-generic-tag-types-function + #'eieio--generic-subclass-tag-types) +(defun eieio--generic-subclass-tag-types (tag) + (when (eieio--class-p tag) + (mapcar (lambda (class) + `(subclass + ,(if (symbolp class) class (eieio--class-symbol class)))) + (eieio--class-precedence-list tag)))) - (if (or (not lambdas) (not (car lambdas))) + +;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "b568ffb3c90ed5d0ae673f0051d608ee") +;;; Generated autoloads from eieio-compat.el - ;; No methods found for this impl... - (if (eieio-object-p (car args)) - (setq rval (apply 'no-applicable-method (car args) method args) - rvalever t) - (signal - 'no-method-definition - (list method args))) +(autoload 'eieio--defalias "eieio-compat" "\ +Like `defalias', but with less side-effects. +More specifically, it has no side-effects at all when the new function +definition is the same (`eq') as the old one. - ;; Do the regular implementation here. +\(fn NAME BODY)" nil nil) - (run-hook-with-args 'eieio-pre-method-execution-functions - lambdas) +(autoload 'defgeneric "eieio-compat" "\ +Create a generic function METHOD. +DOC-STRING is the base documentation for this class. A generic +function has no body, as its purpose is to decide which method body +is appropriate to use. Uses `defmethod' to create methods, and calls +`defgeneric' for you. With this implementation the ARGS are +currently ignored. You can use `defgeneric' to apply specialized +top level documentation to a method. - (setq lastval (apply (car lambdas) newargs)) - (setq rval lastval - rvalever t) - ) +\(fn METHOD ARGS &optional DOC-STRING)" nil t) - ;; Right Here... it could be that lastval is returned when - ;; rvalever is nil. Is that right? - rval)))) - -(defun eieiomt-method-list (method key class) - "Return an alist list of methods lambdas. -METHOD is the method name. -KEY represents either :before, or :after methods. -CLASS is the starting class to search from in the method tree. -If CLASS is nil, then an empty list of methods should be returned." - ;; Note: eieiomt - the MT means MethodTree. See more comments below - ;; for the rest of the eieiomt methods. - - ;; Collect lambda expressions stored for the class and its parent - ;; classes. - (let (lambdas) - (dolist (ancestor (eieio-class-precedence-list class)) - ;; Lookup the form to use for the PRIMARY object for the next level - (let ((tmpl (eieio-generic-form method key ancestor))) - (when (and tmpl - (or (not lambdas) - ;; This prevents duplicates coming out of the - ;; class method optimizer. Perhaps we should - ;; just not optimize before/afters? - (not (member tmpl lambdas)))) - (push tmpl lambdas)))) - - ;; Return collected lambda. For :after methods, return in current - ;; order (most general class last); Otherwise, reverse order. - (if (eq key method-after) - lambdas - (nreverse lambdas)))) +(function-put 'defgeneric 'doc-string-elt '3) + +(make-obsolete 'defgeneric 'cl-defgeneric '"25.1") + +(autoload 'defmethod "eieio-compat" "\ +Create a new METHOD through `defgeneric' with ARGS. + +The optional second argument KEY is a specifier that +modifies how the method is called, including: + :before - Method will be called before the :primary + :primary - The default if not specified + :after - Method will be called after the :primary + :static - First arg could be an object or class +The next argument is the ARGLIST. The ARGLIST specifies the arguments +to the method as with `defun'. The first argument can have a type +specifier, such as: + ((VARNAME CLASS) ARG2 ...) +where VARNAME is the name of the local variable for the method being +created. The CLASS is a class symbol for a class made with `defclass'. +A DOCSTRING comes after the ARGLIST, and is optional. +All the rest of the args are the BODY of the method. A method will +return the value of the last form in the BODY. + +Summary: + + (defmethod mymethod [:before | :primary | :after | :static] + ((typearg class-name) arg2 &optional opt &rest rest) + \"doc-string\" + body) + +\(fn METHOD &rest ARGS)" nil t) + +(function-put 'defmethod 'doc-string-elt '3) + +(make-obsolete 'defmethod 'cl-defmethod '"25.1") + +(autoload 'eieio--defgeneric-init-form "eieio-compat" "\ + + +\(fn METHOD DOC-STRING)" nil nil) + +(autoload 'eieio--defmethod "eieio-compat" "\ - -;;; -;; eieio-method-tree : eieiomt- -;; -;; Stored as eieio-method-tree in property list of a generic method -;; -;; (eieio-method-tree . [BEFORE PRIMARY AFTER -;; genericBEFORE genericPRIMARY genericAFTER]) -;; and -;; (eieio-method-obarray . [BEFORE PRIMARY AFTER -;; genericBEFORE genericPRIMARY genericAFTER]) -;; where the association is a vector. -;; (aref 0 -- all static methods. -;; (aref 1 -- all methods classified as :before -;; (aref 2 -- all methods classified as :primary -;; (aref 3 -- all methods classified as :after -;; (aref 4 -- a generic classified as :before -;; (aref 5 -- a generic classified as :primary -;; (aref 6 -- a generic classified as :after -;; -(defvar eieiomt-optimizing-obarray nil - "While mapping atoms, this contain the obarray being optimized.") - -(defun eieiomt-install (method-name) - "Install the method tree, and obarray onto METHOD-NAME. -Do not do the work if they already exist." - (let ((emtv (get method-name 'eieio-method-tree)) - (emto (get method-name 'eieio-method-obarray))) - (if (or (not emtv) (not emto)) - (progn - (setq emtv (put method-name 'eieio-method-tree - (make-vector method-num-slots nil)) - emto (put method-name 'eieio-method-obarray - (make-vector method-num-slots nil))) - (aset emto 0 (make-vector 11 0)) - (aset emto 1 (make-vector 11 0)) - (aset emto 2 (make-vector 41 0)) - (aset emto 3 (make-vector 11 0)) - )))) - -(defun eieiomt-add (method-name method key class) - "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. -METHOD-NAME is the name created by a call to `defgeneric'. -METHOD are the forms for a given implementation. -KEY is an integer (see comment in eieio.el near this function) which -is associated with the :static :before :primary and :after tags. -It also indicates if CLASS is defined or not. -CLASS is the class this method is associated with." - (if (or (> key method-num-slots) (< key 0)) - (error "eieiomt-add: method key error!")) - (let ((emtv (get method-name 'eieio-method-tree)) - (emto (get method-name 'eieio-method-obarray))) - ;; Make sure the method tables are available. - (if (or (not emtv) (not emto)) - (error "Programmer error: eieiomt-add")) - ;; only add new cells on if it doesn't already exist! - (if (assq class (aref emtv key)) - (setcdr (assq class (aref emtv key)) method) - (aset emtv key (cons (cons class method) (aref emtv key)))) - ;; Add function definition into newly created symbol, and store - ;; said symbol in the correct obarray, otherwise use the - ;; other array to keep this stuff - (if (< key method-num-lists) - (let ((nsym (intern (symbol-name class) (aref emto key)))) - (fset nsym method))) - ;; Save the defmethod file location in a symbol property. - (let ((fname (if load-in-progress - load-file-name - buffer-file-name)) - loc) - (when fname - (when (string-match "\\.elc$" fname) - (setq fname (substring fname 0 (1- (length fname))))) - (setq loc (get method-name 'method-locations)) - (pushnew (list class fname) loc :test 'equal) - (put method-name 'method-locations loc))) - ;; Now optimize the entire obarray - (if (< key method-num-lists) - (let ((eieiomt-optimizing-obarray (aref emto key))) - ;; @todo - Is this overkill? Should we just clear the symbol? - (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray))) - )) -(defun eieiomt-next (class) - "Return the next parent class for CLASS. -If CLASS is a superclass, return variable `eieio-default-superclass'. -If CLASS is variable `eieio-default-superclass' then return nil. -This is different from function `class-parent' as class parent returns -nil for superclasses. This function performs no type checking!" - ;; No type-checking because all calls are made from functions which - ;; are safe and do checking for us. - (or (eieio-class-parents-fast class) - (if (eq class 'eieio-default-superclass) - nil - '(eieio-default-superclass)))) - -(defun eieiomt-sym-optimize (s) - "Find the next class above S which has a function body for the optimizer." - ;; Set the value to nil in case there is no nearest cell. - (set s nil) - ;; Find the nearest cell that has a function body. If we find one, - ;; we replace the nil from above. - (let ((external-symbol (intern-soft (symbol-name s)))) - (catch 'done - (dolist (ancestor (rest (eieio-class-precedence-list external-symbol))) - (let ((ov (intern-soft (symbol-name ancestor) - eieiomt-optimizing-obarray))) - (when (fboundp ov) - (set s ov) ;; store ov as our next symbol - (throw 'done ancestor))))))) - -(defun eieio-generic-form (method key class) - "Return the lambda form belonging to METHOD using KEY based upon CLASS. -If CLASS is not a class then use `generic' instead. If class has -no form, but has a parent class, then trace to that parent class. -The first time a form is requested from a symbol, an optimized path -is memorized for faster future use." - (let ((emto (aref (get method 'eieio-method-obarray) - (if class key (eieio-specialized-key-to-generic-key key))))) - (if (class-p class) - ;; 1) find our symbol - (let ((cs (intern-soft (symbol-name class) emto))) - (if (not cs) - ;; 2) If there isn't one, then make one. - ;; This can be slow since it only occurs once - (progn - (setq cs (intern (symbol-name class) emto)) - ;; 2.1) Cache its nearest neighbor with a quick optimize - ;; which should only occur once for this call ever - (let ((eieiomt-optimizing-obarray emto)) - (eieiomt-sym-optimize cs)))) - ;; 3) If it's bound return this one. - (if (fboundp cs) - (cons cs (eieio--class-symbol (class-v class))) - ;; 4) If it's not bound then this variable knows something - (if (symbol-value cs) - (progn - ;; 4.1) This symbol holds the next class in its value - (setq class (symbol-value cs) - cs (intern-soft (symbol-name class) emto)) - ;; 4.2) The optimizer should always have chosen a - ;; function-symbol - ;;(if (fboundp cs) - (cons cs (eieio--class-symbol (class-v (intern (symbol-name class))))) - ;;(error "EIEIO optimizer: erratic data loss!")) - ) - ;; There never will be a funcall... - nil))) - ;; for a generic call, what is a list, is the function body we want. - (let ((emtl (aref (get method 'eieio-method-tree) - (if class key (eieio-specialized-key-to-generic-key key))))) - (if emtl - ;; The car of EMTL is supposed to be a class, which in this - ;; case is nil, so skip it. - (cons (cdr (car emtl)) nil) - nil))))) +\(fn METHOD KIND ARGCLASS CODE)" nil nil) +(autoload 'eieio-defmethod "eieio-compat" "\ +Obsolete work part of an old version of the `defmethod' macro. + +\(fn METHOD ARGS)" nil nil) + +(make-obsolete 'eieio-defmethod 'cl-defmethod '"24.1") + +(autoload 'eieio-defgeneric "eieio-compat" "\ +Obsolete work part of an old version of the `defgeneric' macro. + +\(fn METHOD DOC-STRING)" nil nil) + +(make-obsolete 'eieio-defgeneric 'cl-defgeneric '"24.1") + +(autoload 'eieio-defclass "eieio-compat" "\ + + +\(fn CNAME SUPERCLASSES SLOTS OPTIONS)" nil nil) + +(make-obsolete 'eieio-defclass 'eieio-defclass-internal '"25.1") + +;;;*** -;;; Here are some special types of errors -;; -(intern "no-method-definition") -(put 'no-method-definition 'error-conditions '(no-method-definition error)) -(put 'no-method-definition 'error-message "No method definition") - -(intern "no-next-method") -(put 'no-next-method 'error-conditions '(no-next-method error)) -(put 'no-next-method 'error-message "No next method") - -(intern "invalid-slot-name") -(put 'invalid-slot-name 'error-conditions '(invalid-slot-name error)) -(put 'invalid-slot-name 'error-message "Invalid slot name") - -(intern "invalid-slot-type") -(put 'invalid-slot-type 'error-conditions '(invalid-slot-type error nil)) -(put 'invalid-slot-type 'error-message "Invalid slot type") - -(intern "unbound-slot") -(put 'unbound-slot 'error-conditions '(unbound-slot error nil)) -(put 'unbound-slot 'error-message "Unbound slot") - -(intern "inconsistent-class-hierarchy") -(put 'inconsistent-class-hierarchy 'error-conditions - '(inconsistent-class-hierarchy error nil)) -(put 'inconsistent-class-hierarchy 'error-message "Inconsistent class hierarchy") - -;;; Obsolete backward compatibility functions. -;; Needed to run byte-code compiled with the EIEIO of Emacs-23. - -(defun eieio-defmethod (method args) - "Obsolete work part of an old version of the `defmethod' macro." - (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) - ;; find optional keys - (setq key - (cond ((memq (car args) '(:BEFORE :before)) - (setq args (cdr args)) - method-before) - ((memq (car args) '(:AFTER :after)) - (setq args (cdr args)) - method-after) - ((memq (car args) '(:STATIC :static)) - (setq args (cdr args)) - method-static) - ((memq (car args) '(:PRIMARY :primary)) - (setq args (cdr args)) - method-primary) - ;; Primary key. - (t method-primary))) - ;; Get body, and fix contents of args to be the arguments of the fn. - (setq body (cdr args) - args (car args)) - (setq loopa args) - ;; Create a fixed version of the arguments. - (while loopa - (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) - argfix)) - (setq loopa (cdr loopa))) - ;; Make sure there is a generic. - (eieio-defgeneric - method - (if (stringp (car body)) - (car body) (format "Generically created method `%s'." method))) - ;; create symbol for property to bind to. If the first arg is of - ;; the form (varname vartype) and `vartype' is a class, then - ;; that class will be the type symbol. If not, then it will fall - ;; under the type `primary' which is a non-specific calling of the - ;; function. - (setq firstarg (car args)) - (if (listp firstarg) - (progn - (setq argclass (nth 1 firstarg)) - (if (not (class-p argclass)) - (error "Unknown class type %s in method parameters" - (nth 1 firstarg)))) - ;; Generics are higher. - (setq key (eieio-specialized-key-to-generic-key key))) - ;; Put this lambda into the symbol so we can find it. - (if (byte-code-function-p (car-safe body)) - (eieiomt-add method (car-safe body) key argclass) - (eieiomt-add method (append (list 'lambda (reverse argfix)) body) - key argclass)) - ) - - (when eieio-optimize-primary-methods-flag - ;; Optimizing step: - ;; - ;; If this method, after this setup, only has primary methods, then - ;; we can setup the generic that way. - (if (generic-primary-only-p method) - ;; If there is only one primary method, then we can go one more - ;; optimization step. - (if (generic-primary-only-one-p method) - (eieio-defgeneric-reset-generic-form-primary-only-one method) - (eieio-defgeneric-reset-generic-form-primary-only method)) - (eieio-defgeneric-reset-generic-form method))) - - method) -(make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1") - -(defun eieio-defgeneric (method doc-string) - "Obsolete work part of an old version of the `defgeneric' macro." - (if (and (fboundp method) (not (generic-p method)) - (or (byte-code-function-p (symbol-function method)) - (not (eq 'autoload (car (symbol-function method))))) - ) - (error "You cannot create a generic/method over an existing symbol: %s" - method)) - ;; Don't do this over and over. - (unless (fboundp 'method) - ;; This defun tells emacs where the first definition of this - ;; method is defined. - `(defun ,method nil) - ;; Make sure the method tables are installed. - (eieiomt-install method) - ;; Apply the actual body of this function. - (fset method (eieio-defgeneric-form method doc-string)) - ;; Return the method - 'method)) -(make-obsolete 'eieio-defgeneric nil "24.1") (provide 'eieio-core) diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 84450d8dfb1..0e0b31e4e7e 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -1,4 +1,4 @@ -;;; eieio-custom.el -- eieio object customization +;;; eieio-custom.el -- eieio object customization -*- lexical-binding:t -*- ;; Copyright (C) 1999-2001, 2005, 2007-2015 Free Software Foundation, ;; Inc. @@ -70,7 +70,7 @@ of these.") :documentation "A number of thingies.")) "A class for testing the widget on.") -(defcustom eieio-widget-test (eieio-widget-test-class "Foo") +(defcustom eieio-widget-test (eieio-widget-test-class) "Test variable for editing an object." :type 'object :group 'eieio) @@ -136,7 +136,7 @@ Updates occur regardless of the current customization group.") )) (widget-value-set vc (widget-value vc)))) -(defun eieio-custom-toggle-parent (widget &rest ignore) +(defun eieio-custom-toggle-parent (widget &rest _) "Toggle visibility of parent of WIDGET. Optional argument IGNORE is an extraneous parameter." (eieio-custom-toggle-hide (widget-get widget :parent))) @@ -154,7 +154,7 @@ Optional argument IGNORE is an extraneous parameter." :clone-object-children nil ) -(defun eieio-object-match (widget value) +(defun eieio-object-match (_widget _value) "Match info for WIDGET against VALUE." ;; Write me t) @@ -184,7 +184,7 @@ Optional argument IGNORE is an extraneous parameter." (if (not (widget-get widget :value)) (widget-put widget :value (cond ((widget-get widget :objecttype) - (funcall (class-constructor + (funcall (eieio--class-constructor (widget-get widget :objecttype)) "Custom-new")) ((widget-get widget :objectcreatefcn) @@ -193,7 +193,7 @@ Optional argument IGNORE is an extraneous parameter." (let* ((chil nil) (obj (widget-get widget :value)) (master-group (widget-get widget :eieio-group)) - (cv (class-v (eieio--object-class obj))) + (cv (eieio--object-class-object obj)) (slots (eieio--class-public-a cv)) (flabel (eieio--class-public-custom-label cv)) (fgroup (eieio--class-public-custom-group cv)) @@ -208,7 +208,8 @@ Optional argument IGNORE is an extraneous parameter." chil))) ;; Display information about the group being shown (when master-group - (let ((groups (class-option (eieio--object-class obj) :custom-groups))) + (let ((groups (eieio--class-option (eieio--object-class-object obj) + :custom-groups))) (widget-insert "Groups:") (while groups (widget-insert " ") @@ -216,7 +217,7 @@ Optional argument IGNORE is an extraneous parameter." (widget-insert "*" (capitalize (symbol-name master-group)) "*") (widget-create 'push-button :thing (cons obj (car groups)) - :notify (lambda (widget &rest stuff) + :notify (lambda (widget &rest _) (eieio-customize-object (car (widget-get widget :thing)) (cdr (widget-get widget :thing)))) @@ -260,8 +261,8 @@ Optional argument IGNORE is an extraneous parameter." (car flabel) (let ((s (symbol-name (or - (class-slot-initarg - (eieio--object-class obj) + (eieio--class-slot-initarg + (eieio--object-class-object obj) (car slots)) (car slots))))) (capitalize @@ -288,7 +289,7 @@ Optional argument IGNORE is an extraneous parameter." "Get the value of WIDGET." (let* ((obj (widget-get widget :value)) (master-group eieio-cog) - (cv (class-v (eieio--object-class obj))) + (cv (eieio--object-class-object obj)) (fgroup (eieio--class-public-custom-group cv)) (wids (widget-get widget :children)) (name (if (widget-get widget :eieio-show-name) @@ -296,7 +297,7 @@ Optional argument IGNORE is an extraneous parameter." nil)) (chil (if (widget-get widget :eieio-show-name) (nthcdr 1 wids) wids)) - (cv (class-v (eieio--object-class obj))) + (cv (eieio--object-class-object obj)) (slots (eieio--class-public-a cv)) (fcust (eieio--class-public-custom cv))) ;; If there are any prefix widgets, clear them. @@ -317,11 +318,11 @@ Optional argument IGNORE is an extraneous parameter." fgroup (cdr fgroup) fcust (cdr fcust))) ;; Set any name updates on it. - (if name (setf (eieio--object-name obj) name)) + (if name (eieio-object-set-name-string obj name)) ;; This is the same object we had before. obj)) -(defmethod eieio-done-customizing ((obj eieio-default-superclass)) +(cl-defmethod eieio-done-customizing ((_obj eieio-default-superclass)) "When applying change to a widget, call this method. This method is called by the default widget-edit commands. User made commands should also call this method when applying changes. @@ -344,7 +345,7 @@ Optional argument GROUP is the sub-group of slots to display." "Major mode for customizing EIEIO objects. \\{eieio-custom-mode-map}") -(defmethod eieio-customize-object ((obj eieio-default-superclass) +(cl-defmethod eieio-customize-object ((obj eieio-default-superclass) &optional group) "Customize OBJ in a specialized custom buffer. To override call the `eieio-custom-widget-insert' to just insert the @@ -383,20 +384,20 @@ These groups are specified with the `:group' slot flag." (make-local-variable 'eieio-co) (setq eieio-co obj) (make-local-variable 'eieio-cog) - (setq eieio-cog group))) + (setq eieio-cog g))) -(defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass)) +(cl-defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass)) "Insert an Apply and Reset button into the object editor. Argument OBJ is the object being customized." (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _) (widget-apply eieio-wo :value-get) (eieio-done-customizing eieio-co) (bury-buffer)) "Accept") (widget-insert " ") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _) ;; I think the act of getting it sets ;; its value through the get function. (message "Applying Changes...") @@ -406,17 +407,17 @@ Argument OBJ is the object being customized." "Apply") (widget-insert " ") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _) (message "Resetting") (eieio-customize-object eieio-co eieio-cog)) "Reset") (widget-insert " ") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _) (bury-buffer)) "Cancel")) -(defmethod eieio-custom-widget-insert ((obj eieio-default-superclass) +(cl-defmethod eieio-custom-widget-insert ((obj eieio-default-superclass) &rest flags) "Insert the widget used for editing object OBJ in the current buffer. Arguments FLAGS are widget compatible flags. @@ -431,13 +432,11 @@ Must return the created widget." :clone-object-children t ) -(defun eieio-object-value-to-abstract (widget value) +(defun eieio-object-value-to-abstract (_widget value) "For WIDGET, convert VALUE to an abstract /safe/ representation." - (if (eieio-object-p value) value - (if (null value) value - nil))) + (if (eieio-object-p value) value)) -(defun eieio-object-abstract-to-value (widget value) +(defun eieio-object-abstract-to-value (_widget value) "For WIDGET, convert VALUE from an abstract /safe/ representation." value) @@ -447,21 +446,22 @@ Must return the created widget." ;; These functions provide the ability to create dynamic menus to ;; customize specific sections of an object. They do not hook directly ;; into a filter, but can be used to create easymenu vectors. -(defmethod eieio-customize-object-group ((obj eieio-default-superclass)) +(cl-defmethod eieio-customize-object-group ((obj eieio-default-superclass)) "Create a list of vectors for customizing sections of OBJ." (mapcar (lambda (group) (vector (concat "Group " (symbol-name group)) (list 'customize-object obj (list 'quote group)) t)) - (class-option (eieio--object-class obj) :custom-groups))) + (eieio--class-option (eieio--object-class-object obj) :custom-groups))) (defvar eieio-read-custom-group-history nil "History for the custom group reader.") -(defmethod eieio-read-customization-group ((obj eieio-default-superclass)) +(cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass)) "Do a completing read on the name of a customization group in OBJ. Return the symbol for the group, or nil" - (let ((g (class-option (eieio--object-class obj) :custom-groups))) + (let ((g (eieio--class-option (eieio--object-class-object obj) + :custom-groups))) (if (= (length g) 1) (car g) ;; Make the association list diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 0a51ecfa203..119f7cce038 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -1,4 +1,4 @@ -;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. +;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -*- lexical-binding:t -*- ;; Copyright (C) 2007-2015 Free Software Foundation, Inc. @@ -79,7 +79,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button." ;; ;; Each object should have an opportunity to show stuff about itself. -(defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) +(cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) prefix) "Insert the slots of OBJ into the current DDEBUG buffer." (let ((inhibit-read-only t)) @@ -87,8 +87,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button." prefix "Name: ") (let* ((cl (eieio-object-class obj)) - (cv (class-v cl))) - (data-debug-insert-thing (class-constructor cl) + (cv (eieio--class-v cl))) + (data-debug-insert-thing (eieio--class-constructor cl) prefix "Class: ") ;; Loop over all the public slots @@ -96,7 +96,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button." ) (while publa (if (slot-boundp obj (car publa)) - (let* ((i (class-slot-initarg cl (car publa))) + (let* ((i (eieio--class-slot-initarg (eieio--class-v cl) + (car publa))) (v (eieio-oref obj (car publa)))) (data-debug-insert-thing v prefix (concat @@ -104,7 +105,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button." (symbol-name (car publa))) " "))) ;; Unbound case - (let ((i (class-slot-initarg cl (car publa)))) + (let ((i (eieio--class-slot-initarg (eieio--class-v cl) + (car publa)))) (data-debug-insert-custom "#unbound" prefix (concat (if i (symbol-name i) @@ -122,27 +124,11 @@ PREBUTTONTEXT is some text between PREFIX and the object button." ;; ;; A generic function to run DDEBUG on an object and popup a new buffer. ;; -(defmethod data-debug-show ((obj eieio-default-superclass)) +(cl-defmethod data-debug-show ((obj eieio-default-superclass)) "Run ddebug against any EIEIO object OBJ." (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj))) (data-debug-insert-object-slots obj "]")) -;;; DEBUG FUNCTIONS -;; -(defun eieio-debug-methodinvoke (method class) - "Show the method invocation order for METHOD with CLASS object." - (interactive "aMethod: \nXClass Expression: ") - (let* ((eieio-pre-method-execution-functions - (lambda (l) (throw 'moose l) )) - (data - (catch 'moose (eieio-generic-call - method (list class)))) - (buf (data-debug-new-buffer "*Method Invocation*")) - (data2 (mapcar (lambda (sym) - (symbol-function (car sym))) - data))) - (data-debug-insert-thing data2 ">" ""))) - (provide 'eieio-datadebug) ;;; eieio-datadebug.el ends here diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 21843025efd..8d40edf5624 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -60,7 +60,7 @@ Argument PREFIX is the character prefix to use. Argument CH-PREFIX is another character prefix to display." (eieio--check-type class-p this-root) (let ((myname (symbol-name this-root)) - (chl (eieio--class-children (class-v this-root))) + (chl (eieio--class-children (eieio--class-v this-root))) (fprefix (concat ch-prefix " +--")) (mprefix (concat ch-prefix " | ")) (lprefix (concat ch-prefix " "))) @@ -81,7 +81,7 @@ If CLASS is actually an object, then also display current values of that object. ;; Header line (prin1 class) (insert " is a" - (if (class-option class :abstract) + (if (eieio--class-option (eieio--class-v class) :abstract) "n abstract" "") " class") @@ -122,34 +122,23 @@ If CLASS is actually an object, then also display current values of that object. ;; Describe all the slots in this class. (eieio-help-class-slots class) ;; Describe all the methods specific to this class. - (let ((methods (eieio-all-generic-functions class)) - (type [":STATIC" ":BEFORE" ":PRIMARY" ":AFTER"]) - counter doc) - (when methods + (let ((generics (eieio-all-generic-functions class))) + (when generics (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) - (while methods - (setq doc (eieio-method-documentation (car methods) class)) - (insert "`") - (help-insert-xref-button (symbol-name (car methods)) - 'help-function (car methods)) - (insert "'") - (if (not doc) - (insert " Undocumented") - (setq counter 0) - (dolist (cur doc) - (when cur - (insert " " (aref type counter) " " - (prin1-to-string (car cur) (current-buffer)) - "\n" - (or (cdr cur) ""))) - (setq counter (1+ counter)))) - (insert "\n\n") - (setq methods (cdr methods)))))) + (dolist (generic generics) + (insert "`") + (help-insert-xref-button (symbol-name generic) 'help-function generic) + (insert "'") + (pcase-dolist (`(,qualifiers ,args ,doc) + (eieio-method-documentation generic class)) + (insert (format " %s%S\n" qualifiers args) + (or doc ""))) + (insert "\n\n"))))) (defun eieio-help-class-slots (class) "Print help description for the slots in CLASS. Outputs to the current buffer." - (let* ((cv (class-v class)) + (let* ((cv (eieio--class-v class)) (docs (eieio--class-public-doc cv)) (names (eieio--class-public-a cv)) (deflt (eieio--class-public-d cv)) @@ -218,11 +207,10 @@ Outputs to the current buffer." (defun eieio-build-class-list (class) "Return a list of all classes that inherit from CLASS." (if (class-p class) - (apply #'append - (mapcar - (lambda (c) - (append (list c) (eieio-build-class-list c))) - (eieio-class-children-fast class))) + (cl-mapcan + (lambda (c) + (append (list c) (eieio-build-class-list c))) + (eieio--class-children (eieio--class-v class))) (list class))) (defun eieio-build-class-alist (&optional class instantiable-only buildlist) @@ -231,15 +219,16 @@ Optional argument CLASS is the class to start with. If INSTANTIABLE-ONLY is non nil, only allow names of classes which are not abstract, otherwise allow all classes. Optional argument BUILDLIST is more list to attach and is used internally." - (let* ((cc (or class eieio-default-superclass)) - (sublst (eieio--class-children (class-v cc)))) + (let* ((cc (or class 'eieio-default-superclass)) + (sublst (eieio--class-children (eieio--class-v cc)))) (unless (assoc (symbol-name cc) buildlist) (when (or (not instantiable-only) (not (class-abstract-p cc))) + ;; FIXME: Completion tables don't need alists, and ede/generic.el needs + ;; the symbols rather than their names. (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) - (while sublst + (dolist (elem sublst) (setq buildlist (eieio-build-class-alist - (car sublst) instantiable-only buildlist)) - (setq sublst (cdr sublst))) + elem instantiable-only buildlist))) buildlist)) (defvar eieio-read-class nil @@ -311,140 +300,50 @@ are not abstract." (eieio-help-class ctr)) )))) - -;;;###autoload -(defun eieio-help-generic (generic) - "Describe GENERIC if it is a generic function." - (when (and (symbolp generic) (generic-p generic)) - (save-excursion - (goto-char (point-min)) - (when (re-search-forward " in `.+'.$" nil t) - (replace-match "."))) - (save-excursion - (insert "\n\nThis is a generic function" - (cond - ((and (generic-primary-only-p generic) - (generic-primary-only-one-p generic)) - " with only one primary method") - ((generic-primary-only-p generic) - " with only primary methods") - (t "")) - ".\n\n") - (insert (propertize "Implementations:\n\n" 'face 'bold)) - (let ((i 4) - (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) - ;; Loop over fanciful generics - (while (< i 7) - (let ((gm (aref (get generic 'eieio-method-tree) i))) - (when gm - (insert "Generic " - (aref prefix (- i 3)) - "\n" - (or (nth 2 gm) "Undocumented") - "\n\n"))) - (setq i (1+ i))) - (setq i 0) - ;; Loop over defined class-specific methods - (while (< i 4) - (let* ((gm (reverse (aref (get generic 'eieio-method-tree) i))) - cname location) - (while gm - (setq cname (caar gm)) - (insert "`") - (help-insert-xref-button (symbol-name cname) - 'help-variable cname) - (insert "' " (aref prefix i) " ") - ;; argument list - (let* ((func (cdr (car gm))) - (arglst (eieio-lambda-arglist func))) - (prin1 arglst (current-buffer))) - (insert "\n" - (or (documentation (cdr (car gm))) - "Undocumented")) - ;; Print file location if available - (when (and (setq location (get generic 'method-locations)) - (setq location (assoc cname location))) - (setq location (cadr location)) - (insert "\n\nDefined in `") - (help-insert-xref-button - (file-name-nondirectory location) - 'eieio-method-def cname generic location) - (insert "'\n")) - (setq gm (cdr gm)) - (insert "\n"))) - (setq i (1+ i))))))) - -(defun eieio-lambda-arglist (func) - "Return the argument list of FUNC, a function body." - (if (symbolp func) (setq func (symbol-function func))) - (if (byte-code-function-p func) - (eieio-compiled-function-arglist func) - (car (cdr func)))) +(defun eieio--specializers-apply-to-class-p (specializers class) + "Return non-nil if a method with SPECIALIZERS applies to CLASS." + (let ((applies nil)) + (dolist (specializer specializers) + (if (eq 'subclass (car-safe specializer)) + (setq specializer (nth 1 specializer))) + ;; Don't include the methods that are "too generic", such as those + ;; applying to `eieio-default-superclass'. + (and (not (memq specializer '(t eieio-default-superclass))) + (class-p specializer) + (child-of-class-p class specializer) + (setq applies t))) + applies)) (defun eieio-all-generic-functions (&optional class) "Return a list of all generic functions. Optional CLASS argument returns only those functions that contain methods for CLASS." - (let ((l nil) tree (cn (if class (symbol-name class) nil))) + (let ((l nil)) (mapatoms (lambda (symbol) - (setq tree (get symbol 'eieio-method-obarray)) - (if tree - (progn - ;; A symbol might be interned for that class in one of - ;; these three slots in the method-obarray. - (if (or (not class) - (fboundp (intern-soft cn (aref tree 0))) - (fboundp (intern-soft cn (aref tree 1))) - (fboundp (intern-soft cn (aref tree 2)))) - (setq l (cons symbol l))))))) + (let ((generic (and (fboundp symbol) (cl--generic symbol)))) + (and generic + (catch 'found + (if (null class) (throw 'found t)) + (dolist (method (cl--generic-method-table generic)) + (if (eieio--specializers-apply-to-class-p + (cl--generic-method-specializers method) class) + (throw 'found t)))) + (push symbol l))))) l)) (defun eieio-method-documentation (generic class) - "Return a list of the specific documentation of GENERIC for CLASS. -If there is not an explicit method for CLASS in GENERIC, or if that -function has no documentation, then return nil." - (let ((tree (get generic 'eieio-method-obarray)) - (cn (symbol-name class)) - before primary after) - (if (not tree) - nil - ;; A symbol might be interned for that class in one of - ;; these three slots in the method-obarray. - (setq before (intern-soft cn (aref tree 0)) - primary (intern-soft cn (aref tree 1)) - after (intern-soft cn (aref tree 2))) - (if (not (or (fboundp before) - (fboundp primary) - (fboundp after))) - nil - (list (if (fboundp before) - (cons (eieio-lambda-arglist before) - (documentation before)) - nil) - (if (fboundp primary) - (cons (eieio-lambda-arglist primary) - (documentation primary)) - nil) - (if (fboundp after) - (cons (eieio-lambda-arglist after) - (documentation after)) - nil)))))) - -(defvar eieio-read-generic nil - "History of the `eieio-read-generic' prompt.") - -(defun eieio-read-generic-p (fn) - "Function used in function `eieio-read-generic'. -This is because `generic-p' is a macro. -Argument FN is the function to test." - (generic-p fn)) - -(defun eieio-read-generic (prompt &optional historyvar) - "Read a generic function from the minibuffer with PROMPT. -Optional argument HISTORYVAR is the variable to use as history." - (intern (completing-read prompt obarray 'eieio-read-generic-p - t nil (or historyvar 'eieio-read-generic)))) + "Return info for all methods of GENERIC applicable to CLASS. +The value returned is a list of elements of the form +\(QUALIFIERS ARGS DOC)." + (let ((generic (cl--generic generic)) + (docs ())) + (when generic + (dolist (method (cl--generic-method-table generic)) + (when (eieio--specializers-apply-to-class-p + (cl--generic-method-specializers method) class) + (push (cl--generic-method-info method) docs)))) + docs)) ;;; METHOD STATS ;; @@ -634,21 +533,21 @@ Optional argument HISTORYVAR is the variable to use as history." () "Menu part in easymenu format used in speedbar while in `eieio' mode.") -(defun eieio-class-speedbar (dir-or-object depth) +(defun eieio-class-speedbar (_dir-or-object _depth) "Create buttons in speedbar that represents the current project. DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the current expansion depth." (when (eq (point-min) (point-max)) ;; This function is only called once, to start the whole deal. ;; Create and expand the default object. - (eieio-class-button eieio-default-superclass 0) + (eieio-class-button 'eieio-default-superclass 0) (forward-line -1) (speedbar-expand-line))) (defun eieio-class-button (class depth) "Draw a speedbar button at the current point for CLASS at DEPTH." (eieio--check-type class-p class) - (let ((subclasses (eieio--class-children (class-v class)))) + (let ((subclasses (eieio--class-children (eieio--class-v class)))) (if subclasses (speedbar-make-tag-line 'angle ?+ 'eieio-sb-expand @@ -673,7 +572,7 @@ Argument INDENT is the depth of indentation." (speedbar-with-writable (save-excursion (end-of-line) (forward-char 1) - (let ((subclasses (eieio--class-children (class-v class)))) + (let ((subclasses (eieio--class-children (eieio--class-v class)))) (while subclasses (eieio-class-button (car subclasses) (1+ indent)) (setq subclasses (cdr subclasses))))))) @@ -683,7 +582,7 @@ Argument INDENT is the depth of indentation." (t (error "Ooops... not sure what to do"))) (speedbar-center-buffer-smartly)) -(defun eieio-describe-class-sb (text token indent) +(defun eieio-describe-class-sb (_text token _indent) "Describe the class TEXT in TOKEN. INDENT is the current indentation level." (dframe-with-attached-buffer diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index cf676256d43..a1eabcf9700 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -1,4 +1,4 @@ -;;; eieio-speedbar.el -- Classes for managing speedbar displays. +;;; eieio-speedbar.el -- Classes for managing speedbar displays. -*- lexical-binding:t -*- ;; Copyright (C) 1999-2002, 2005, 2007-2015 Free Software Foundation, ;; Inc. @@ -196,19 +196,19 @@ that path." ;; when no other methods are found, allowing multiple inheritance to work ;; reliably with eieio-speedbar. -(defmethod eieio-speedbar-description (object) +(cl-defmethod eieio-speedbar-description (object) "Return a string describing OBJECT." (eieio-object-name-string object)) -(defmethod eieio-speedbar-derive-line-path (object) +(cl-defmethod eieio-speedbar-derive-line-path (_object) "Return the path which OBJECT has something to do with." nil) -(defmethod eieio-speedbar-object-buttonname (object) +(cl-defmethod eieio-speedbar-object-buttonname (object) "Return a string to use as a speedbar button for OBJECT." (eieio-object-name-string object)) -(defmethod eieio-speedbar-make-tag-line (object depth) +(cl-defmethod eieio-speedbar-make-tag-line (object depth) "Insert a tag line into speedbar at point for OBJECT. By default, all objects appear as simple TAGS with no need to inherit from the special `eieio-speedbar' classes. Child classes should redefine this @@ -221,7 +221,7 @@ Argument DEPTH is the depth at which the tag line is inserted." 'speedbar-tag-face depth)) -(defmethod eieio-speedbar-handle-click (object) +(cl-defmethod eieio-speedbar-handle-click (object) "Handle a click action on OBJECT in speedbar. Any object can be represented as a tag in SPEEDBAR without special attributes. These default objects will be pulled up in a custom @@ -285,7 +285,7 @@ Add one of the child classes to this class to the parent list of a class." ;;; Methods to eieio-speedbar-* which do not need to be overridden ;; -(defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) +(cl-defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) depth) "Insert a tag line into speedbar at point for OBJECT. All objects a child of symbol `eieio-speedbar' can be created from @@ -321,12 +321,12 @@ Argument DEPTH is the depth at which the tag line is inserted." (if exp (eieio-speedbar-expand object (1+ depth)))))) -(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth) +(cl-defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) _depth) "Base method for creating tag lines for non-object children." (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s" (eieio-object-name object))) -(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) +(cl-defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) "Expand OBJECT at indentation DEPTH. Inserts a list of new tag lines representing expanded elements within OBJECT." @@ -340,7 +340,7 @@ OBJECT." ;;; Speedbar specific function callbacks. ;; -(defun eieio-speedbar-object-click (text token indent) +(defun eieio-speedbar-object-click (_text token _indent) "Handle a user click on TEXT representing object TOKEN. The object is at indentation level INDENT." (eieio-speedbar-handle-click token)) @@ -362,7 +362,7 @@ TOKEN is the object. INDENT is the current indentation level." (t (error "Ooops... not sure what to do"))) (speedbar-center-buffer-smartly)) -(defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) +(cl-defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) "Return a description for a child of OBJ which is not an object." (error "You must implement `eieio-speedbar-child-description' for %s" (eieio-object-name obj))) @@ -412,7 +412,7 @@ Optional DEPTH is the depth we start at." ;;; Methods to the eieio-speedbar-* classes which need to be overridden. ;; -(defmethod eieio-speedbar-object-children ((object eieio-speedbar)) +(cl-defmethod eieio-speedbar-object-children ((_object eieio-speedbar)) "Return a list of children to be displayed in speedbar. If the return value is a list of OBJECTs, then those objects are queried for details. If the return list is made of strings, diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 1ae1e594b29..91469b4b96c 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-2015 Free Software Foundation, Inc. @@ -36,15 +36,13 @@ ;; Retrieved from: ;; http://192.220.96.201/dylan/linearization-oopsla96.html -;; There is funny stuff going on with typep and deftype. This -;; is the only way I seem to be able to make this stuff load properly. - ;; @TODO - fix :initform to be a form, not a quoted value ;; @TODO - Prefix non-clos functions with `eieio-'. -;;; Code: +;; TODO: better integrate CL's defstructs and classes. E.g. make it possible +;; to create a new class that inherits from a struct. -(eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! +;;; Code: (defvar eieio-version "1.4" "Current version of EIEIO.") @@ -59,13 +57,11 @@ ;;; Defining a new class ;; -(defmacro defclass (name superclass slots &rest options-and-doc) +(defmacro defclass (name superclasses slots &rest options-and-doc) "Define NAME as a new class derived from SUPERCLASS with SLOTS. OPTIONS-AND-DOC is used as the class' options and base documentation. -SUPERCLASS is a list of superclasses to inherit from, with SLOTS -being the slots residing in that class definition. NOTE: Currently -only one slot may exist in SUPERCLASS as multiple inheritance is not -yet supported. Supported tags are: +SUPERCLASSES is a list of superclasses to inherit from, with SLOTS +being the slots residing in that class definition. Supported tags are: :initform - Initializing form. :initarg - Tag used during initialization. @@ -79,8 +75,6 @@ yet supported. Supported tags are: - A string documenting use of this slot. The following are extensions on CLOS: - :protection - Specify protection for this slot. - Defaults to `:public'. Also use `:protected', or `:private'. :custom - When customizing an object, the custom :type. Public only. :label - A text string label used for a slot when customizing. :group - Name of a customization group this slot belongs in. @@ -115,12 +109,179 @@ Options in CLOS not supported in EIEIO: Due to the way class options are set up, you can add any tags you wish, and reference them using the function `class-option'." - ;; This is eval-and-compile only to silence spurious compiler warnings - ;; about functions and variables not known to be defined. - ;; When eieio-defclass code is merged here and this becomes - ;; transparent to the compiler, the eval-and-compile can be removed. - `(eval-and-compile - (eieio-defclass ',name ',superclass ',slots ',options-and-doc))) + (declare (doc-string 4)) + (eieio--check-type listp superclasses) + + (cond ((and (stringp (car options-and-doc)) + (/= 1 (% (length options-and-doc) 2))) + (error "Too many arguments to `defclass'")) + ((and (symbolp (car options-and-doc)) + (/= 0 (% (length options-and-doc) 2))) + (error "Too many arguments to `defclass'"))) + + (if (stringp (car options-and-doc)) + (setq options-and-doc + (cons :documentation options-and-doc))) + + ;; Make sure the method invocation order is a valid value. + (let ((io (eieio--class-option-assoc options-and-doc + :method-invocation-order))) + (when (and io (not (member io '(:depth-first :breadth-first :c3)))) + (error "Method invocation order %s is not allowed" io))) + + (let ((testsym1 (intern (concat (symbol-name name) "-p"))) + (testsym2 (intern (format "eieio--childp--%s" name))) + (accessors ())) + + ;; Collect the accessors we need to define. + (pcase-dolist (`(,sname . ,soptions) slots) + (let* ((acces (plist-get soptions :accessor)) + (initarg (plist-get soptions :initarg)) + (reader (plist-get soptions :reader)) + (writer (plist-get soptions :writer)) + (alloc (plist-get soptions :allocation)) + (label (plist-get soptions :label))) + + (if eieio-error-unsupported-class-tags + (let ((tmp soptions)) + (while tmp + (if (not (member (car tmp) '(:accessor + :initform + :initarg + :documentation + :protection + :reader + :writer + :allocation + :type + :custom + :label + :group + :printer + :allow-nil-initform + :custom-groups))) + (signal 'invalid-slot-type (list (car tmp)))) + (setq tmp (cdr (cdr tmp)))))) + + ;; Make sure the :allocation parameter has a valid value. + (if (not (memq alloc '(nil :class :instance))) + (signal 'invalid-slot-type (list :allocation alloc))) + + ;; Label is nil, or a string + (if (not (or (null label) (stringp label))) + (signal 'invalid-slot-type (list :label label))) + + ;; Is there an initarg, but allocation of class? + (if (and initarg (eq alloc :class)) + (message "Class allocated slots do not need :initarg")) + + ;; Anyone can have an accessor function. This creates a function + ;; of the specified name, and also performs a `defsetf' if applicable + ;; so that users can `setf' the space returned by this function. + (when acces + (push `(cl-defmethod (setf ,acces) (value (this ,name)) + (eieio-oset this ',sname value)) + accessors) + (push `(cl-defmethod ,acces ((this ,name)) + ,(format + "Retrieve the slot `%S' from an object of class `%S'." + sname name) + ;; FIXME: Why is this different from the :reader case? + (if (slot-boundp this ',sname) (eieio-oref this ',sname))) + accessors) + (when (and eieio-backward-compatibility (eq alloc :class)) + ;; FIXME: How could I declare this *method* as obsolete. + (push `(cl-defmethod ,acces ((this (subclass ,name))) + ,(format + "Retrieve the class slot `%S' from a class `%S'. +This method is obsolete." + sname name) + (if (slot-boundp this ',sname) + (eieio-oref-default this ',sname))) + accessors))) + + ;; If a writer is defined, then create a generic method of that + ;; name whose purpose is to set the value of the slot. + (if writer + (push `(cl-defmethod ,writer ((this ,name) value) + ,(format "Set the slot `%S' of an object of class `%S'." + sname name) + (setf (slot-value this ',sname) value)) + accessors)) + ;; If a reader is defined, then create a generic method + ;; of that name whose purpose is to access this slot value. + (if reader + (push `(cl-defmethod ,reader ((this ,name)) + ,(format "Access the slot `%S' from object of class `%S'." + sname name) + (slot-value this ',sname)) + accessors)) + )) + + `(progn + ;; This test must be created right away so we can have self- + ;; referencing classes. ei, a class whose slot can contain only + ;; pointers to itself. + + ;; Create the test function. + (defun ,testsym1 (obj) + ,(format "Test OBJ to see if it an object of type %S." name) + (and (eieio-object-p obj) + (same-class-p obj ',name))) + + (defun ,testsym2 (obj) + ,(format + "Test OBJ to see if it an object is a child of type %S." + name) + (and (eieio-object-p obj) + (object-of-class-p obj ',name))) + + ,@(when eieio-backward-compatibility + (let ((f (intern (format "%s-child-p" name)))) + `((defalias ',f ',testsym2) + (make-obsolete + ',f ,(format "use (cl-typep ... '%s) instead" name) "25.1")))) + + ;; When using typep, (typep OBJ 'myclass) returns t for objects which + ;; are subclasses of myclass. For our predicates, however, it is + ;; important for EIEIO to be backwards compatible, where + ;; myobject-p, and myobject-child-p are different. + ;; "cl" uses this technique to specify symbols with specific typep + ;; test, so we can let typep have the CLOS documented behavior + ;; while keeping our above predicate clean. + + (put ',name 'cl-deftype-satisfies #',testsym2) + + (eieio-defclass-internal ',name ',superclasses ',slots ',options-and-doc) + + ,@accessors + + ;; Create the constructor function + ,(if (eieio--class-option-assoc options-and-doc :abstract) + ;; Abstract classes cannot be instantiated. Say so. + (let ((abs (eieio--class-option-assoc options-and-doc :abstract))) + (if (not (stringp abs)) + (setq abs (format "Class %s is abstract" name))) + `(defun ,name (&rest _) + ,(format "You cannot create a new object of type %S." name) + (error ,abs))) + + ;; Non-abstract classes need a constructor. + `(defun ,name (&rest slots) + ,(format "Create a new object with name NAME of class type %S." + name) + (declare (compiler-macro + (lambda (whole) + (if (not (stringp (car slots))) + whole + (macroexp--warn-and-return + (format "Obsolete name arg %S to constructor %S" + (car slots) (car whole)) + ;; Keep the name arg, for backward compatibility, + ;; but hide it so we don't trigger indefinitely. + `(,(car whole) (identity ,(car slots)) + ,@(cdr slots))))))) + (apply #'eieio-constructor ',name slots)))))) ;;; CLOS style implementation of object creators. @@ -145,73 +306,16 @@ In EIEIO, the class' constructor requires a name for use when printing. `make-instance' in CLOS doesn't use names the way Emacs does, so the class is used as the name slot instead when INITARGS doesn't start with a string." - (if (and (car initargs) (stringp (car initargs))) - (apply (class-constructor class) initargs) - (apply (class-constructor class) - (cond ((symbolp class) (symbol-name class)) - (t (format "%S" class))) - initargs))) + (apply (eieio--class-constructor class) initargs)) -;;; CLOS methods and generics -;; -(defmacro defgeneric (method args &optional doc-string) - "Create a generic function METHOD. -DOC-STRING is the base documentation for this class. A generic -function has no body, as its purpose is to decide which method body -is appropriate to use. Uses `defmethod' to create methods, and calls -`defgeneric' for you. With this implementation the ARGS are -currently ignored. You can use `defgeneric' to apply specialized -top level documentation to a method." - `(eieio--defalias ',method - (eieio--defgeneric-init-form ',method ,doc-string))) - -(defmacro defmethod (method &rest args) - "Create a new METHOD through `defgeneric' with ARGS. - -The optional second argument KEY is a specifier that -modifies how the method is called, including: - :before - Method will be called before the :primary - :primary - The default if not specified - :after - Method will be called after the :primary - :static - First arg could be an object or class -The next argument is the ARGLIST. The ARGLIST specifies the arguments -to the method as with `defun'. The first argument can have a type -specifier, such as: - ((VARNAME CLASS) ARG2 ...) -where VARNAME is the name of the local variable for the method being -created. The CLASS is a class symbol for a class made with `defclass'. -A DOCSTRING comes after the ARGLIST, and is optional. -All the rest of the args are the BODY of the method. A method will -return the value of the last form in the BODY. - -Summary: - - (defmethod mymethod [:before | :primary | :after | :static] - ((typearg class-name) arg2 &optional opt &rest rest) - \"doc-string\" - body)" - (let* ((key (if (keywordp (car args)) (pop args))) - (params (car args)) - (arg1 (car params)) - (fargs (if (consp arg1) - (cons (car arg1) (cdr params)) - params)) - (class (if (consp arg1) (nth 1 arg1))) - (code `(lambda ,fargs ,@(cdr args)))) - `(progn - ;; Make sure there is a generic and the byte-compiler sees it. - (defgeneric ,method ,args - ,(or (documentation code) - (format "Generically created method `%s'." method))) - (eieio--defmethod ',method ',key ',class #',code)))) - ;;; Get/Set slots in an object. ;; (defmacro oref (obj slot) "Retrieve the value stored in OBJ in the slot named by SLOT. Slot is the name of the slot when created by `defclass' or the label created by the :initarg tag." + (declare (debug (form symbolp))) `(eieio-oref ,obj (quote ,slot))) (defalias 'slot-value 'eieio-oref) @@ -222,6 +326,7 @@ created by the :initarg tag." The default value is the value installed in a class with the :initform tag. SLOT can be the slot name, or the tag specified by the :initarg tag in the `defclass' call." + (declare (debug (form symbolp))) `(eieio-oref-default ,obj (quote ,slot))) ;;; Handy CLOS macros @@ -245,7 +350,8 @@ SPEC-LIST is of a form similar to `let'. For example: Where each VAR is the local variable given to the associated SLOT. A slot specified without a variable name is given a variable name of the same name as the slot." - (declare (indent 2)) + (declare (indent 2) (debug (sexp sexp def-body))) + (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)) @@ -259,33 +365,45 @@ variable name of the same name as the slot." ;; well embedded into an object. ;; (define-obsolete-function-alias - 'object-class-fast #'eieio--object-class "24.4") + 'object-class-fast #'eieio--object-class-name "24.4") + +(cl-defgeneric eieio-object-name-string (obj) + "Return a string which is OBJ's name." + (declare (obsolete eieio-named "25.1"))) (defun eieio-object-name (obj &optional extra) "Return a Lisp like symbol string for object OBJ. If EXTRA, include that in the string returned to represent the symbol." (eieio--check-type eieio-object-p obj) - (format "#<%s %s%s>" (symbol-name (eieio--object-class obj)) - (eieio--object-name obj) (or extra ""))) + (format "#<%s %s%s>" (eieio--object-class-name obj) + (eieio-object-name-string obj) (or extra ""))) (define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") -(defun eieio-object-name-string (obj) "Return a string which is OBJ's name." - (eieio--check-type eieio-object-p obj) - (eieio--object-name obj)) +(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key)) + +;; In the past, every EIEIO object had a `name' field, so we had the two method +;; below "for free". Since this field is very rarely used, we got rid of it +;; and instead we keep it in a weak hash-tables, for those very rare objects +;; that use it. +(cl-defmethod eieio-object-name-string (obj) + (or (gethash obj eieio--object-names) + (symbol-name (eieio-object-class obj)))) (define-obsolete-function-alias 'object-name-string #'eieio-object-name-string "24.4") -(defun eieio-object-set-name-string (obj name) +(cl-defmethod eieio-object-set-name-string (obj name) "Set the string which is OBJ's NAME." - (eieio--check-type eieio-object-p obj) + (declare (obsolete eieio-named "25.1")) (eieio--check-type stringp name) - (setf (eieio--object-name obj) name)) + (setf (gethash obj eieio--object-names) name)) (define-obsolete-function-alias 'object-set-name-string 'eieio-object-set-name-string "24.4") -(defun eieio-object-class (obj) "Return the class struct defining OBJ." +(defun eieio-object-class (obj) + "Return the class struct defining OBJ." + ;; FIXME: We say we return a "struct" but we return a symbol instead! (eieio--check-type eieio-object-p obj) - (eieio--object-class obj)) + (eieio--object-class-name obj)) (define-obsolete-function-alias 'object-class #'eieio-object-class "24.4") ;; CLOS name, maybe? (define-obsolete-function-alias 'class-of #'eieio-object-class "24.4") @@ -293,7 +411,7 @@ If EXTRA, include that in the string returned to represent the symbol." (defun eieio-object-class-name (obj) "Return a Lisp like symbol name for OBJ's class." (eieio--check-type eieio-object-p obj) - (eieio-class-name (eieio--object-class obj))) + (eieio-class-name (eieio--object-class-name obj))) (define-obsolete-function-alias 'object-class-name 'eieio-object-class-name "24.4") @@ -301,15 +419,16 @@ If EXTRA, include that in the string returned to represent the symbol." "Return parent classes to CLASS. (overload of variable). The CLOS function `class-direct-superclasses' is aliased to this function." - (eieio--check-type class-p class) - (eieio-class-parents-fast class)) + (let ((c (eieio-class-object class))) + (eieio--class-parent c))) + (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") (defun eieio-class-children (class) "Return child classes to CLASS. The CLOS function `class-direct-subclasses' is aliased to this function." (eieio--check-type class-p class) - (eieio-class-children-fast class)) + (eieio--class-children (eieio--class-v class))) (define-obsolete-function-alias 'class-children #'eieio-class-children "24.4") @@ -324,38 +443,44 @@ The CLOS function `class-direct-subclasses' is aliased to this function." `(car (eieio-class-parents ,class))) (define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4") -(defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." - (eieio--check-type class-p class) +(defun same-class-p (obj class) + "Return t if OBJ is of class-type CLASS." + (setq class (eieio--class-object class)) + (eieio--check-type eieio--class-p class) (eieio--check-type eieio-object-p obj) - (same-class-fast-p obj class)) + (eq (eieio--object-class-object obj) class)) (defun object-of-class-p (obj class) "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." (eieio--check-type eieio-object-p obj) ;; class will be checked one layer down - (child-of-class-p (eieio--object-class obj) class)) + (child-of-class-p (eieio--object-class-object obj) class)) ;; Backwards compatibility (defalias 'obj-of-class-p 'object-of-class-p) (defun child-of-class-p (child class) "Return non-nil if CHILD class is a subclass of CLASS." - (eieio--check-type class-p class) - (eieio--check-type class-p child) - (let ((p nil)) - (while (and child (not (eq child class))) - (setq p (append p (eieio--class-parent (class-v child))) - child (car p) - p (cdr p))) - (if child t))) + (setq child (eieio--class-object child)) + (eieio--check-type eieio--class-p child) + ;; `eieio-default-superclass' is never mentioned in eieio--class-parent, + ;; so we have to special case it here. + (or (eq class 'eieio-default-superclass) + (let ((p nil)) + (setq class (eieio--class-object class)) + (eieio--check-type eieio--class-p class) + (while (and child (not (eq child class))) + (setq p (append p (eieio--class-parent child)) + child (pop p))) + (if child t)))) (defun object-slots (obj) "Return list of slots available in OBJ." (eieio--check-type eieio-object-p obj) - (eieio--class-public-a (class-v (eieio--object-class obj)))) + (eieio--class-public-a (eieio--object-class-object obj))) -(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." - (eieio--check-type class-p class) - (let ((ia (eieio--class-initarg-tuples (class-v class))) +(defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." + (eieio--check-type eieio--class-p class) + (let ((ia (eieio--class-initarg-tuples class)) (f nil)) (while (and ia (not f)) (if (eq (cdr (car ia)) slot) @@ -369,6 +494,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function." "Set the value in OBJ for slot SLOT to VALUE. SLOT is the slot name as specified in `defclass' or the tag created with in the :initarg slot. VALUE can be any Lisp object." + (declare (debug (form symbolp form))) `(eieio-oset ,obj (quote ,slot) ,value)) (defmacro oset-default (class slot value) @@ -376,6 +502,7 @@ with in the :initarg slot. VALUE can be any Lisp object." The default value is usually set with the :initform tag during class creation. This allows users to change the default behavior of classes after they are created." + (declare (debug (form symbolp form))) `(eieio-oset-default ,class (quote ,slot) ,value)) ;;; CLOS queries into classes and slots @@ -400,11 +527,9 @@ OBJECT can be an instance or a class." (defun slot-exists-p (object-or-class slot) "Return non-nil if OBJECT-OR-CLASS has SLOT." - (let ((cv (class-v (cond ((eieio-object-p object-or-class) - (eieio-object-class object-or-class)) - ((class-p object-or-class) - object-or-class)) - ))) + (let ((cv (cond ((eieio-object-p object-or-class) + (eieio--object-class-object object-or-class)) + (t (eieio-class-object object-or-class))))) (or (memq slot (eieio--class-public-a cv)) (memq slot (eieio--class-class-allocation-a cv))) )) @@ -416,7 +541,7 @@ If ERRORP is non-nil, `wrong-argument-type' is signaled." (if (not (class-p symbol)) (if errorp (signal 'wrong-type-argument (list 'class-p symbol)) nil) - (class-v symbol))) + (eieio--class-v symbol))) ;;; Slightly more complex utility functions for objects ;; @@ -494,68 +619,10 @@ If SLOT is unbound, do nothing." nil (eieio-oset object slot (delete item (eieio-oref object slot))))) -;;; -;; Method Calling Functions - -(defun next-method-p () - "Return non-nil if there is a next method. -Returns a list of lambda expressions which is the `next-method' -order." - eieio-generic-call-next-method-list) - -(defun call-next-method (&rest replacement-args) - "Call the superclass method from a subclass method. -The superclass method is specified in the current method list, -and is called the next method. - -If REPLACEMENT-ARGS is non-nil, then use them instead of -`eieio-generic-call-arglst'. The generic arg list are the -arguments passed in at the top level. - -Use `next-method-p' to find out if there is a next method to call." - (if (not (eieio--scoped-class)) - (error "`call-next-method' not called within a class specific method")) - (if (and (/= eieio-generic-call-key method-primary) - (/= eieio-generic-call-key method-static)) - (error "Cannot `call-next-method' except in :primary or :static methods") - ) - (let ((newargs (or replacement-args eieio-generic-call-arglst)) - (next (car eieio-generic-call-next-method-list)) - ) - (if (or (not next) (not (car next))) - (apply 'no-next-method (car newargs) (cdr newargs)) - (let* ((eieio-generic-call-next-method-list - (cdr eieio-generic-call-next-method-list)) - (eieio-generic-call-arglst newargs) - (fcn (car next)) - ) - (eieio--with-scoped-class (cdr next) - (apply fcn newargs)) )))) - ;;; Here are some CLOS items that need the CL package ;; -(defsetf eieio-oref eieio-oset) - -(if (eval-when-compile (fboundp 'gv-define-expander)) - ;; Not needed for Emacs>=24.3 since gv.el's setf expands macros and - ;; follows aliases. - nil -(defsetf slot-value eieio-oset) - -;; The below setf method was written by Arnd Kohrs <kohrs@acm.org> -(define-setf-method oref (obj slot) - (with-no-warnings - (require 'cl) - (let ((obj-temp (gensym)) - (slot-temp (gensym)) - (store-temp (gensym))) - (list (list obj-temp slot-temp) - (list obj `(quote ,slot)) - (list store-temp) - (list 'set-slot-value obj-temp slot-temp - store-temp) - (list 'slot-value obj-temp slot-temp)))))) +(gv-define-simple-setter eieio-oref eieio-oset) ;;; @@ -574,48 +641,55 @@ Its slots are automatically adopted by classes with no specified parents. This class is not stored in the `parent' slot of a class vector." :abstract t) +(setq eieio-default-superclass (eieio--class-v 'eieio-default-superclass)) + (defalias 'standard-class 'eieio-default-superclass) -(defgeneric constructor (class newname &rest slots) +(cl-defgeneric eieio-constructor (class &rest slots) "Default constructor for CLASS `eieio-default-superclass'.") -(defmethod constructor :static - ((class eieio-default-superclass) newname &rest slots) +(define-obsolete-function-alias 'constructor #'eieio-constructor "25.1") + +(cl-defmethod eieio-constructor + ((class (subclass eieio-default-superclass)) &rest slots) "Default constructor for CLASS `eieio-default-superclass'. -NEWNAME is the name to be given to the constructed object. SLOTS are the initialization slots used by `shared-initialize'. This static method is called when an object is constructed. It allocates the vector used to represent an EIEIO object, and then calls `shared-initialize' on that object." - (let* ((new-object (copy-sequence (eieio--class-default-object-cache (class-v class))))) - ;; Update the name for the newly created object. - (setf (eieio--object-name new-object) newname) + (let* ((new-object (copy-sequence (eieio--class-default-object-cache + (eieio--class-v class))))) + (if (and slots + (let ((x (car slots))) + (or (stringp x) (null x)))) + (funcall (if eieio-backward-compatibility #'ignore #'message) + "Obsolete name %S passed to %S constructor" + (pop slots) class)) ;; Call the initialize method on the new object with the slots ;; that were passed down to us. (initialize-instance new-object slots) ;; Return the created object. new-object)) -(defgeneric shared-initialize (obj slots) +(cl-defgeneric shared-initialize (obj slots) "Set slots of OBJ with SLOTS which is a list of name/value pairs. Called from the constructor routine.") -(defmethod shared-initialize ((obj eieio-default-superclass) slots) +(cl-defmethod shared-initialize ((obj eieio-default-superclass) slots) "Set slots of OBJ with SLOTS which is a list of name/value pairs. Called from the constructor routine." - (eieio--with-scoped-class (eieio--object-class obj) - (while slots - (let ((rn (eieio-initarg-to-attribute (eieio--object-class obj) - (car slots)))) - (if (not rn) - (slot-missing obj (car slots) 'oset (car (cdr slots))) - (eieio-oset obj rn (car (cdr slots))))) - (setq slots (cdr (cdr slots)))))) - -(defgeneric initialize-instance (this &optional slots) + (while slots + (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj) + (car slots)))) + (if (not rn) + (slot-missing obj (car slots) 'oset (car (cdr slots))) + (eieio-oset obj rn (car (cdr slots))))) + (setq slots (cdr (cdr slots))))) + +(cl-defgeneric initialize-instance (this &optional slots) "Construct the new object THIS based on SLOTS.") -(defmethod initialize-instance ((this eieio-default-superclass) +(cl-defmethod initialize-instance ((this eieio-default-superclass) &optional slots) "Construct the new object THIS based on SLOTS. SLOTS is a tagged list where odd numbered elements are tags, and @@ -627,7 +701,7 @@ not taken, then new objects of your class will not have their values dynamically set from SLOTS." ;; First, see if any of our defaults are `lambda', and ;; re-evaluate them and apply the value to our slots. - (let* ((this-class (class-v (eieio--object-class this))) + (let* ((this-class (eieio--object-class-object this)) (slot (eieio--class-public-a this-class)) (defaults (eieio--class-public-d this-class))) (while slot @@ -647,11 +721,11 @@ dynamically set from SLOTS." ;; Shared initialize will parse our slots for us. (shared-initialize this slots)) -(defgeneric slot-missing (object slot-name operation &optional new-value) +(cl-defgeneric slot-missing (object slot-name operation &optional new-value) "Method invoked when an attempt to access a slot in OBJECT fails.") -(defmethod slot-missing ((object eieio-default-superclass) slot-name - operation &optional new-value) +(cl-defmethod slot-missing ((object eieio-default-superclass) slot-name + _operation &optional _new-value) "Method invoked when an attempt to access a slot in OBJECT fails. SLOT-NAME is the name of the failed slot, OPERATION is the type of access that was requested, and optional NEW-VALUE is the value that was desired @@ -662,10 +736,10 @@ directly reference slots in EIEIO objects." (signal 'invalid-slot-name (list (eieio-object-name object) slot-name))) -(defgeneric slot-unbound (object class slot-name fn) +(cl-defgeneric slot-unbound (object class slot-name fn) "Slot unbound is invoked during an attempt to reference an unbound slot.") -(defmethod slot-unbound ((object eieio-default-superclass) +(cl-defmethod slot-unbound ((object eieio-default-superclass) class slot-name fn) "Slot unbound is invoked during an attempt to reference an unbound slot. OBJECT is the instance of the object being reference. CLASS is the @@ -680,75 +754,40 @@ EIEIO can only dispatch on the first argument, so the first two are swapped." (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) slot-name fn))) -(defgeneric no-applicable-method (object method &rest args) - "Called if there are no implementations for OBJECT in METHOD.") - -(defmethod no-applicable-method ((object eieio-default-superclass) - method &rest args) - "Called if there are no implementations for OBJECT in METHOD. -OBJECT is the object which has no method implementation. -ARGS are the arguments that were passed to METHOD. - -Implement this for a class to block this signal. The return -value becomes the return value of the original method call." - (signal 'no-method-definition (list method (eieio-object-name object))) - ) - -(defgeneric no-next-method (object &rest args) -"Called from `call-next-method' when no additional methods are available.") - -(defmethod no-next-method ((object eieio-default-superclass) - &rest args) - "Called from `call-next-method' when no additional methods are available. -OBJECT is othe object being called on `call-next-method'. -ARGS are the arguments it is called by. -This method signals `no-next-method' by default. Override this -method to not throw an error, and its return value becomes the -return value of `call-next-method'." - (signal 'no-next-method (list (eieio-object-name object) args)) - ) - -(defgeneric clone (obj &rest params) +(cl-defgeneric clone (obj &rest params) "Make a copy of OBJ, and then supply PARAMS. PARAMS is a parameter list of the same form used by `initialize-instance'. When overloading `clone', be sure to call `call-next-method' first and modify the returned object.") -(defmethod clone ((obj eieio-default-superclass) &rest params) +(cl-defmethod clone ((obj eieio-default-superclass) &rest params) "Make a copy of OBJ, and then apply PARAMS." - (let ((nobj (copy-sequence obj)) - (nm (eieio--object-name obj)) - (passname (and params (stringp (car params)))) - (num 1)) - (if params (shared-initialize nobj (if passname (cdr params) params))) - (if (not passname) - (save-match-data - (if (string-match "-\\([0-9]+\\)" nm) - (setq num (1+ (string-to-number (match-string 1 nm))) - nm (substring nm 0 (match-beginning 0)))) - (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num)))) - (setf (eieio--object-name nobj) (car params))) + (let ((nobj (copy-sequence obj))) + (if (stringp (car params)) + (funcall (if eieio-backward-compatibility #'ignore #'message) + "Obsolete name %S passed to clone" (pop params))) + (if params (shared-initialize nobj params)) nobj)) -(defgeneric destructor (this &rest params) +(cl-defgeneric destructor (this &rest params) "Destructor for cleaning up any dynamic links to our object.") -(defmethod destructor ((this eieio-default-superclass) &rest params) +(cl-defmethod destructor ((_this eieio-default-superclass) &rest _params) "Destructor for cleaning up any dynamic links to our object. Argument THIS is the object being destroyed. PARAMS are additional ignored parameters." ;; No cleanup... yet. ) -(defgeneric object-print (this &rest strings) +(cl-defgeneric object-print (this &rest strings) "Pretty printer for object THIS. Call function `object-name' with STRINGS. It is sometimes useful to put a summary of the object into the default #<notation> string when using EIEIO browsing tools. Implement this method to customize the summary.") -(defmethod object-print ((this eieio-default-superclass) &rest strings) +(cl-defmethod object-print ((this eieio-default-superclass) &rest strings) "Pretty printer for object THIS. Call function `object-name' with STRINGS. The default method for printing object THIS is to use the function `object-name'. @@ -760,16 +799,16 @@ Implement this function and specify STRINGS in a call to `call-next-method' to provide additional summary information. When passing in extra strings from child classes, always remember to prepend a space." - (eieio-object-name this (apply 'concat strings))) + (eieio-object-name this (apply #'concat strings))) (defvar eieio-print-depth 0 "When printing, keep track of the current indentation depth.") -(defgeneric object-write (this &optional comment) +(cl-defgeneric object-write (this &optional comment) "Write out object THIS to the current stream. Optional COMMENT will add comments to the beginning of the output.") -(defmethod object-write ((this eieio-default-superclass) &optional comment) +(cl-defmethod object-write ((this eieio-default-superclass) &optional comment) "Write object THIS out to the current stream. This writes out the vector version of this object. Complex and recursive object are discouraged from being written. @@ -782,14 +821,14 @@ this object." (princ comment) (princ "\n")) (let* ((cl (eieio-object-class this)) - (cv (class-v cl))) + (cv (eieio--class-v cl))) ;; Now output readable lisp to recreate this object ;; It should look like this: ;; (<constructor> <name> <slot> <slot> ... ) ;; Each slot's slot is writen using its :writer. (princ (make-string (* eieio-print-depth 2) ? )) (princ "(") - (princ (symbol-name (class-constructor (eieio-object-class this)))) + (princ (symbol-name (eieio--class-constructor (eieio-object-class this)))) (princ " ") (prin1 (eieio-object-name-string this)) (princ "\n") @@ -800,7 +839,7 @@ this object." (eieio-print-depth (1+ eieio-print-depth))) (while publa (when (slot-boundp this (car publa)) - (let ((i (class-slot-initarg cl (car publa))) + (let ((i (eieio--class-slot-initarg cv (car publa))) (v (eieio-oref this (car publa))) ) (unless (or (not i) (equal v (car publd))) @@ -859,64 +898,40 @@ this object." ;;; Unimplemented functions from CLOS ;; -(defun change-class (obj class) +(defun change-class (_obj _class) "Change the class of OBJ to type CLASS. This may create or delete slots, but does not affect the return value of `eq'." (error "EIEIO: `change-class' is unimplemented")) ;; Hook ourselves into help system for describing classes and methods. -(add-hook 'help-fns-describe-function-functions 'eieio-help-generic) (add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) ;;; Interfacing with edebug ;; -(defun eieio-edebug-prin1-to-string (object &optional noescape) +(defun eieio-edebug-prin1-to-string (print-function object &optional noescape) "Display EIEIO OBJECT in fancy format. -Overrides the edebug default. -Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." - (cond ((class-p object) (eieio-class-name object)) + +Used as advice around `edebug-prin1-to-string', held in the +variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to +`prin1-to-string' when appropriate." + (cond ((eieio--class-p object) (eieio-class-name object)) ((eieio-object-p object) (object-print object)) - ((and (listp object) (or (class-p (car object)) + ((and (listp object) (or (eieio--class-p (car object)) (eieio-object-p (car object)))) - (concat "(" (mapconcat 'eieio-edebug-prin1-to-string object " ") ")")) - (t (prin1-to-string object noescape)))) - -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec defmethod - (&define ; this means we are defining something - [&or name ("setf" :name setf name)] - ;; ^^ This is the methods symbol - [ &optional symbolp ] ; this is key :before etc - list ; arguments - [ &optional stringp ] ; documentation string - def-body ; part to be debugged - )) - ;; The rest of the macros - (def-edebug-spec oref (form quote)) - (def-edebug-spec oref-default (form quote)) - (def-edebug-spec oset (form quote form)) - (def-edebug-spec oset-default (form quote form)) - (def-edebug-spec class-v form) - (def-edebug-spec class-p form) - (def-edebug-spec eieio-object-p form) - (def-edebug-spec class-constructor form) - (def-edebug-spec generic-p form) - (def-edebug-spec with-slots (list list def-body)) - ;; I suspect this isn't the best way to do this, but when - ;; cust-print was used on my system all my objects - ;; appeared as "#1 =" which was not useful. This allows - ;; edebug to print my objects in the nice way they were - ;; meant to with `object-print' and `class-name' - ;; (defalias 'edebug-prin1-to-string 'eieio-edebug-prin1-to-string) - ) - ) + (concat "(" (mapconcat + (lambda (x) (eieio-edebug-prin1-to-string print-function x)) + object " ") + ")")) + (t (funcall print-function object noescape)))) + +(advice-add 'edebug-prin1-to-string + :around #'eieio-edebug-prin1-to-string) ;;; Start of automatically extracted autoloads. -;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "f15421ce19e293c6f84c825545ce0b8d") +;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "2ec91e473fcad1ff20cd76edc4aab706") ;;; Generated autoloads from eieio-custom.el (autoload 'customize-object "eieio-custom" "\ @@ -927,7 +942,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;*** -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "fc27fb3e17d23e43ad99d98572aa7b19") +;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "b849f8bf1312d5ef57e53d02173e4b5a") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ @@ -948,11 +963,6 @@ Describe CTR if it is a class constructor. \(fn CTR)" nil nil) -(autoload 'eieio-help-generic "eieio-opt" "\ -Describe GENERIC if it is a generic function. - -\(fn GENERIC)" nil nil) - ;;;*** ;;; End of automatically extracted autoloads. diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 9542bc3b8b1..d527d676d51 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-2015 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,12 @@ the variables `eldoc-argument-case' and `eldoc-echo-area-use-multiline-p', and the face `eldoc-highlight-function-argument', if they are to have any effect. -This variable is expected to be made buffer-local by modes (other than -Emacs Lisp mode) that support ElDoc.") +Major modes should modify this variable using `add-function', for example: + (add-function :before-until (local 'eldoc-documentation-function) + #'foo-mode-eldoc-function) +so that the global documentation function (i.e. the default value of the +variable) is taken into account if the major mode specific function does not +return any documentation.") (defun eldoc-print-current-symbol-info () ;; This is run from post-command-hook or some idle timer thing, @@ -323,240 +352,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 +369,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 +379,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 3af43fbf142..4ffd8cd8558 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 71e8865b01f..7ea13d4637b 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -1,4 +1,4 @@ -;;; find-func.el --- find the definition of the Emacs Lisp function near point +;;; find-func.el --- find the definition of the Emacs Lisp function near point -*- lexical-binding:t -*- ;; Copyright (C) 1997, 1999, 2001-2015 Free Software Foundation, Inc. @@ -59,7 +59,7 @@ (concat "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ -foo\\|[^icfgv]\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ +foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ menu-bar-make-toggle\\)" find-function-space-re "\\('\\|\(quote \\)?%s\\(\\s-\\|$\\|\(\\|\)\\)") @@ -106,7 +106,10 @@ Please send improvements and fixes to the maintainer." (defface . find-face-regexp)) "Alist mapping definition types into regexp variables. Each regexp variable's value should actually be a format string -to be used to substitute the desired symbol name into the regexp.") +to be used to substitute the desired symbol name into the regexp. +Instead of regexp variable, types can be mapped to functions as well, +in which case the function is called with one argument (the object +we're looking for) and it should search for it.") (put 'find-function-regexp-alist 'risky-local-variable t) (defcustom find-function-source-path nil @@ -178,8 +181,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.") @@ -283,35 +285,78 @@ The search is done in the source for library LIBRARY." (let* ((filename (find-library-name library)) (regexp-symbol (cdr (assq type find-function-regexp-alist)))) (with-current-buffer (find-file-noselect filename) - (let ((regexp (format (symbol-value regexp-symbol) - ;; Entry for ` (backquote) macro in loaddefs.el, - ;; (defalias (quote \`)..., has a \ but - ;; (symbol-name symbol) doesn't. Add an - ;; optional \ to catch this. - (concat "\\\\?" - (regexp-quote (symbol-name symbol))))) + (let ((regexp (if (functionp regexp-symbol) regexp-symbol + (format (symbol-value regexp-symbol) + ;; Entry for ` (backquote) macro in loaddefs.el, + ;; (defalias (quote \`)..., has a \ but + ;; (symbol-name symbol) doesn't. Add an + ;; optional \ to catch this. + (concat "\\\\?" + (regexp-quote (symbol-name symbol)))))) (case-fold-search)) (with-syntax-table emacs-lisp-mode-syntax-table (goto-char (point-min)) - (if (or (re-search-forward regexp nil t) - ;; `regexp' matches definitions using known forms like - ;; `defun', or `defvar'. But some functions/variables - ;; are defined using special macros (or functions), so - ;; if `regexp' can't find the definition, we look for - ;; something of the form "(SOMETHING <symbol> ...)". - ;; This fails to distinguish function definitions from - ;; variable declarations (or even uses thereof), but is - ;; a good pragmatic fallback. - (re-search-forward - (concat "^([^ ]+" find-function-space-re "['(]?" - (regexp-quote (symbol-name symbol)) - "\\_>") - nil t)) + (if (if (functionp regexp) + (funcall regexp symbol) + (or (re-search-forward regexp nil t) + ;; `regexp' matches definitions using known forms like + ;; `defun', or `defvar'. But some functions/variables + ;; are defined using special macros (or functions), so + ;; if `regexp' can't find the definition, we look for + ;; something of the form "(SOMETHING <symbol> ...)". + ;; This fails to distinguish function definitions from + ;; variable declarations (or even uses thereof), but is + ;; a good pragmatic fallback. + (re-search-forward + (concat "^([^ ]+" find-function-space-re "['(]?" + (regexp-quote (symbol-name symbol)) + "\\_>") + nil t))) (progn (beginning-of-line) (cons (current-buffer) (point))) (cons (current-buffer) nil)))))))) +(defun find-function-library (function &optional lisp-only verbose) + "Return the pair (ORIG-FUNCTION . LIBRARY) for FUNCTION. + +ORIG-FUNCTION is the original name, after removing all advice and +resolving aliases. LIBRARY is an absolute file name, a relative +file name inside the C sources directory, or a name of an +autoloaded feature. + +If ORIG-FUNCTION is a built-in function and LISP-ONLY is non-nil, +signal an error. + +If VERBOSE is non-nil, and FUNCTION is an alias, display a +message about the whole chain of aliases." + (let ((def (if (symbolp function) + (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 (and def (symbolp def)) + (or (eq def function) + (not verbose) + (setq aliases (if aliases + (concat aliases + (format ", which is an alias for `%s'" + (symbol-name def))) + (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)) + (cons function + (cond + ((autoloadp def) (nth 1 def)) + ((subrp def) + (if lisp-only + (error "%s is a built-in function" function)) + (help-C-file-name def 'subr)) + ((symbol-file function 'defun)))))) + ;;;###autoload (defun find-function-noselect (function &optional lisp-only) "Return a pair (BUFFER . POINT) pointing to the definition of FUNCTION. @@ -330,30 +375,8 @@ searched for in `find-function-source-path' if non-nil, otherwise in `load-path'." (if (not function) (error "You didn't specify a function")) - (let ((def (symbol-function (find-function-advised-original function))) - aliases) - ;; FIXME for completeness, it might be nice to print something like: - ;; foo (which is advised), which is an alias for bar (which is advised). - (while (symbolp def) - (or (eq def function) - (if aliases - (setq aliases (concat aliases - (format ", which is an alias for `%s'" - (symbol-name def)))) - (setq aliases (format "`%s' is an alias for `%s'" - function (symbol-name def))))) - (setq function (symbol-function (find-function-advised-original function)) - def (symbol-function (find-function-advised-original function)))) - (if aliases - (message "%s" aliases)) - (let ((library - (cond ((autoloadp def) (nth 1 def)) - ((subrp def) - (if lisp-only - (error "%s is a built-in function" function)) - (help-C-file-name def 'subr)) - ((symbol-file function 'defun))))) - (find-function-search-for-symbol function nil library)))) + (let ((func-lib (find-function-library function lisp-only t))) + (find-function-search-for-symbol (car func-lib) nil (cdr func-lib)))) (defun find-function-read (&optional type) "Read and return an interned symbol, defaulting to the one near point. @@ -392,7 +415,6 @@ See also `find-function-after-hook'. Set mark before moving, if the buffer already existed." (let* ((orig-point (point)) - (orig-buf (window-buffer)) (orig-buffers (buffer-list)) (buffer-point (save-excursion (find-definition-noselect symbol type))) diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el deleted file mode 100644 index ccefc094127..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-2015 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 bc87f131164..5d6e6e1b372 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..c3f696feda1 --- /dev/null +++ b/lisp/emacs-lisp/inline.el @@ -0,0 +1,262 @@ +;;; inline.el --- Define functions by their inliner -*- lexical-binding:t; -*- + +;; Copyright (C) 2014-2015 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package provides the macro `define-inline' which lets you define +;; functions by defining their (exhaustive) compiler macro. +;; +;; The idea is that instead of doing like defsubst and cl-defsubst (i.e. from +;; the function's definition, guess the best way to inline the function), +;; we go the other way around: the programmer provides the code that does the +;; inlining (as a compiler-macro) and from that we derive the definition of the +;; function itself. The idea originated in an attempt to clean up `cl-typep', +;; whose function definition amounted to (eval (cl--make-type-test EXP TYPE)). +;; +;; The simplest use is for plain and simple inlinable functions. Rather than: +;; +;; (defmacro myaccessor (obj) +;; (macroexp-let2 macroexp-copyable-p obj obj +;; `(if (foop ,obj) (aref (cdr ,obj) 3) (aref ,obj 2)))) +;; Or +;; (defsubst myaccessor (obj) +;; (if (foop obj) (aref (cdr obj) 3) (aref obj 2))) +;; Or +;; (cl-defsubst myaccessor (obj) +;; (if (foop obj) (aref (cdr obj) 3) (aref obj 2))) +;; +;; You'd do +;; +;; (define-inline myaccessor (obj) +;; (inline-letevals (obj) +;; (inline-quote (if (foop ,obj) (aref (cdr ,obj) 3) (aref ,obj 2))))) +;; +;; Other than verbosity, you get the best of all 3 above without their +;; respective downsides: +;; - defmacro: can't be passed to `mapcar' since it's not a function. +;; - defsubst: not as efficient, and doesn't work as a `gv' place. +;; - cl-defsubst: only works by accident, since it has latent bugs in its +;; handling of variables and scopes which could bite you at any time. +;; (e.g. try (cl-defsubst my-test1 (x) (let ((y 5)) (+ x y))) +;; and then M-: (macroexpand-all '(my-test1 y)) RET) +;; There is still one downside shared with the defmacro and cl-defsubst +;; approach: when the function is inlined, the scoping rules (dynamic or +;; lexical) will be inherited from the the call site. + +;; Of course, since define-inline defines a compiler macro, you can also do +;; call-site optimizations, just like you can with `defmacro', but not with +;; defsubst nor cl-defsubst. + +;;; Code: + +(require 'macroexp) + +(defmacro inline-quote (_exp) + "Similar to backquote, but quotes code and only accepts , and not ,@." + (declare (debug t)) + (error "inline-quote can only be used within define-inline")) + +(defmacro inline-const-p (_exp) + "Return non-nil if the value of EXP is already known." + (declare (debug t)) + (error "inline-const-p can only be used within define-inline")) + +(defmacro inline-const-val (_exp) + "Return the value of EXP." + (declare (debug t)) + (error "inline-const-val can only be used within define-inline")) + +(defmacro inline-error (_format &rest _args) + "Signal an error." + (declare (debug t)) + (error "inline-error can only be used within define-inline")) + +(defmacro inline--leteval (_var-exp &rest _body) + (declare (indent 1) (debug (sexp &rest body))) + (error "inline-letevals can only be used within define-inline")) +(defmacro inline--letlisteval (_list &rest _body) + (declare (indent 1) (debug (sexp &rest body))) + (error "inline-letevals can only be used within define-inline")) + +(defmacro inline-letevals (vars &rest body) + "Make sure the expressions in VARS are evaluated. +VARS should be a list of elements of the form (VAR EXP) or just VAR, in case +EXP is equal to VAR. The result is to evaluate EXP and bind the result to VAR. + +The tail of VARS can be either nil or a symbol VAR which should hold a list +of arguments,in which case each argument is evaluated and the resulting +new list is re-bound to VAR. + +After VARS is handled, BODY is evaluated in the new environment." + (declare (indent 1) (debug (sexp &rest form))) + (cond + ((consp vars) + `(inline--leteval ,(pop vars) (inline-letevals ,vars ,@body))) + (vars + `(inline--letlisteval ,vars ,@body)) + (t (macroexp-progn body)))) + +;; (defmacro inline-if (testfun testexp then else) +;; (declare (indent 2) (debug (sexp symbolp form form))) +;; (macroexp-let2 macroexp-copyable-p testsym testexp +;; `(if (inline-const-p ,testexp) +;; (if (,testfun (inline-const-val ,testexp)) ,then ,else) +;; (inline-quote (if (,testfun ,testexp) ,(list '\, then) +;; ,(list '\, else)))))) + +;;;###autoload +(defmacro define-inline (name args &rest body) + ;; FIXME: How can this work with CL arglists? + (declare (indent defun) (debug defun) (doc-string 3)) + (let ((doc (if (stringp (car-safe body)) (list (pop body)))) + (declares (if (eq (car-safe (car-safe body)) 'declare) (pop body))) + (cm-name (intern (format "%s--inliner" name))) + (bodyexp (macroexp-progn body))) + ;; If the function is autoloaded then when we load the .el file, the + ;; `compiler-macro' property is already set (from loaddefs.el) and might + ;; hence be called during the macroexpand-all calls below (if the function + ;; is recursive). + ;; So we disable any pre-loaded compiler-macro setting to avoid this. + (function-put name 'compiler-macro nil) + `(progn + (defun ,name ,args + ,@doc + (declare (compiler-macro ,cm-name) ,@(cdr declares)) + ,(macroexpand-all bodyexp + `((inline-quote . inline--dont-quote) + ;; (inline-\` . inline--dont-quote) + (inline--leteval . inline--dont-leteval) + (inline--letlisteval . inline--dont-letlisteval) + (inline-const-p . inline--alwaysconst-p) + (inline-const-val . inline--alwaysconst-val) + (inline-error . inline--error) + ,@macroexpand-all-environment))) + :autoload-end + (eval-and-compile + (defun ,cm-name ,(cons 'inline--form args) + (ignore inline--form) ;In case it's not used! + (catch 'inline--just-use + ,(macroexpand-all + bodyexp + `((inline-quote . inline--do-quote) + ;; (inline-\` . inline--do-quote) + (inline--leteval . inline--do-leteval) + (inline--letlisteval + . inline--do-letlisteval) + (inline-const-p . inline--testconst-p) + (inline-const-val . inline--getconst-val) + (inline-error . inline--warning) + ,@macroexpand-all-environment)))))))) + +(defun inline--do-quote (exp) + (pcase exp + (`(,'\, ,e) e) ;Eval `e' now *and* later. + (`'(,'\, ,e) `(list 'quote ,e)) ;Only eval `e' now, not later. + (`#'(,'\, ,e) `(list 'function ,e)) ;Only eval `e' now, not later. + ((pred consp) + (let ((args ())) + (while (and (consp exp) (not (eq '\, (car exp)))) + (push (inline--do-quote (pop exp)) args)) + (setq args (nreverse args)) + (if exp + `(backquote-list* ,@args ,(inline--do-quote exp)) + `(list ,@args)))) + (_ (macroexp-quote exp)))) + +(defun inline--dont-quote (exp) + (pcase exp + (`(,'\, ,e) e) + (`'(,'\, ,e) e) + (`#'(,'\, ,e) e) + ((pred consp) + (let ((args ())) + (while (and (consp exp) (not (eq '\, (car exp)))) + (push (inline--dont-quote (pop exp)) args)) + (setq args (nreverse args)) + (if exp + `(apply ,@args ,(inline--dont-quote exp)) + args))) + (_ exp))) + +(defun inline--do-leteval (var-exp &rest body) + `(macroexp-let2 ,(if (symbolp var-exp) #'macroexp-copyable-p #'ignore) + ,(or (car-safe var-exp) var-exp) + ,(or (car (cdr-safe var-exp)) var-exp) + ,@body)) + +(defun inline--dont-leteval (var-exp &rest body) + (if (symbolp var-exp) + (macroexp-progn body) + `(let (,var-exp) ,@body))) + +(defun inline--do-letlisteval (listvar &rest body) + ;; Here's a sample situation: + ;; (define-inline foo (arg &rest keys) + ;; (inline-letevals (arg . keys) + ;; <check-keys>)) + ;; I.e. in <check-keys> we need `keys' to contain a list of + ;; macroexp-copyable-p expressions. + (let ((bsym (make-symbol "bindings"))) + `(let* ((,bsym ()) + (,listvar (mapcar (lambda (e) + (if (macroexp-copyable-p e) e + (let ((v (make-symbol "v"))) + (push (list v e) ,bsym) + v))) + ,listvar))) + (macroexp-let* (nreverse ,bsym) + ,(macroexp-progn body))))) + +(defun inline--dont-letlisteval (_listvar &rest body) + (macroexp-progn body)) + +(defun inline--testconst-p (exp) + (macroexp-let2 macroexp-copyable-p exp exp + `(or (macroexp-const-p ,exp) + (eq (car-safe ,exp) 'function)))) + +(defun inline--alwaysconst-p (_exp) + t) + +(defun inline--getconst-val (exp) + (macroexp-let2 macroexp-copyable-p exp exp + `(cond + ((not ,(inline--testconst-p exp)) + (throw 'inline--just-use inline--form)) + ((consp ,exp) (cadr ,exp)) + (t ,exp)))) + +(defun inline--alwaysconst-val (exp) + exp) + +(defun inline--error (&rest args) + `(error ,@args)) + +(defun inline--warning (&rest _args) + `(throw 'inline--just-use + ;; FIXME: This would inf-loop by calling us right back when + ;; macroexpand-all recurses to expand inline--form. + ;; (macroexp--warn-and-return (format ,@args) + ;; inline--form) + inline--form)) + +(provide 'inline) +;;; inline.el ends here diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 6073de51639..868a9578b0d 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 f8ca6f6a172..214bed7622d 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 bd619bc83b7..797de9abb5b 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,55 @@ 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-macroexpand (form env) + "Like `macroexpand' but checking obsolescence." + (let ((new-form + (macroexpand form env))) + (if (and (not (eq form new-form)) ;It was a macro call. + (car-safe form) + (symbolp (car form)) + (get (car form) 'byte-obsolete-info) + (or (not (fboundp 'byte-compile-warning-enabled-p)) + (byte-compile-warning-enabled-p 'obsolete))) + (let* ((fun (car form)) + (obsolete (get fun 'byte-obsolete-info))) + (macroexp--warn-and-return + (macroexp--obsolete-warning + fun obsolete + (if (symbolp (symbol-function fun)) + "alias" "macro")) + new-form)) + new-form))) + (defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. Assumes the caller has bound `macroexpand-all-environment'." - (if (and (listp form) (eq (car form) 'backquote-list*)) + (if (eq (car-safe form) 'backquote-list*) ;; Special-case `backquote-list*', as it is normally a macro that ;; generates exceedingly deep expansions from relatively shallow input ;; forms. We just process it `in reverse' -- first we expand all the @@ -156,24 +200,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexpand (macroexp--all-forms form 1) macroexpand-all-environment) ;; Normal form; get its expansion, and then expand arguments. - (let ((new-form - (macroexpand form macroexpand-all-environment))) - (setq form - (if (and (not (eq form new-form)) ;It was a macro call. - (car-safe form) - (symbolp (car form)) - (get (car form) 'byte-obsolete-info) - (or (not (fboundp 'byte-compile-warning-enabled-p)) - (byte-compile-warning-enabled-p 'obsolete))) - (let* ((fun (car form)) - (obsolete (get fun 'byte-obsolete-info))) - (macroexp--warn-and-return - (macroexp--obsolete-warning - fun obsolete - (if (symbolp (symbol-function fun)) - "alias" "macro")) - new-form)) - new-form))) + (setq form (macroexp-macroexpand form macroexpand-all-environment)) (pcase form (`(cond . ,clauses) (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) @@ -225,6 +252,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 +269,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 +347,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 +407,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 +454,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 +477,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 8a3c0cc9800..faebe269044 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-x.el b/lisp/emacs-lisp/package-x.el index f2bcdad1720..e0945d47a45 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -207,6 +207,10 @@ if it exists." (pkg-version (package-version-join split-version)) (pkg-buffer (current-buffer))) + ;; `package-upload-file' will error if given a directory, + ;; but we check it here as well just in case. + (when (eq 'dir file-type) + (user-error "Can't upload directory, tar it instead")) ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or ;; from `package-archive-upload-base' otherwise. (let ((contents (or (package--archive-contents-from-url archive-url) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 5203e74dc64..88fc950ee21 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." @@ -226,6 +228,23 @@ a package can run arbitrary code." :group 'package :version "24.1") +(defcustom package-archive-priorities nil + "An alist of priorities for packages. + +Each element has the form (ARCHIVE-ID . PRIORITY). + +When installing packages, the package with the highest version +number from the archive with the highest priority is +selected. When higher versions are available from archives with +lower priorities, the user has to select those manually. + +Archives not in this list have the priority 0." + :type '(alist :key-type (string :tag "Archive name") + :value-type (integer :tag "Priority (default is 0)")) + :risky t + :group 'package + :version "25.1") + (defcustom package-pinned-packages nil "An alist of packages that are pinned to specific archives. This can be useful if you have multiple package archives enabled, @@ -289,6 +308,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) @@ -393,6 +414,7 @@ Slots: (pcase (package-desc-kind pkg-desc) (`single ".el") (`tar ".tar") + (`dir "") (kind (error "Unknown package kind: %s" kind)))) (defun package-desc--keywords (pkg-desc) @@ -512,7 +534,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 +546,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 +577,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 +661,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 +732,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 +772,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,21 +793,29 @@ 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)) (dirname (package-desc-full-name pkg-desc)) (pkg-dir (expand-file-name dirname package-user-dir))) (pcase (package-desc-kind pkg-desc) + (`dir + (make-directory pkg-dir t) + (let ((file-list + (directory-files + default-directory 'full "\\`[^.].*\\.el\\'" 'nosort))) + (dolist (source-file file-list) + (let ((target-el-file + (expand-file-name (file-name-nondirectory source-file) pkg-dir))) + (copy-file source-file target-el-file t))) + ;; Now that the files have been installed, this package is + ;; indistinguishable from a `tar' or a `single'. Let's make + ;; things simple by ensuring we're one of them. + (setf (package-desc-kind pkg-desc) + (if (> (length file-list) 1) 'tar 'single)))) (`tar (make-directory package-user-dir t) ;; FIXME: should we delete PKG-DIR if it exists? @@ -806,13 +889,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 +915,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,15 +934,16 @@ 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." + ;; This won't happen, unless the archive is doing something wrong. + (when (eq (package-desc-kind pkg-desc) 'dir) + (error "Can't install directory package from archive")) (let* ((location (package-archive-base pkg-desc)) (file (concat (package-desc-full-name pkg-desc) (package-desc-suffix pkg-desc))) @@ -1050,23 +1149,34 @@ Also, add the originating archive to the `package-desc' structure." ;; Older archive-contents files have only 4 ;; elements here. (package--ac-desc-extras (cdr package))))) - (existing-packages (assq name package-archive-contents)) (pinned-to-archive (assoc name package-pinned-packages))) - (cond - ;; Skip entirely if pinned to another archive. - ((and pinned-to-archive - (not (equal (cdr pinned-to-archive) archive))) - nil) - ((not existing-packages) - (push (list name pkg-desc) package-archive-contents)) - (t - (while - (if (and (cdr existing-packages) - (version-list-< - version (package-desc-version (cadr existing-packages)))) - (setq existing-packages (cdr existing-packages)) - (push pkg-desc (cdr existing-packages)) - nil)))))) + ;; Skip entirely if pinned to another archive. + (when (not (and pinned-to-archive + (not (equal (cdr pinned-to-archive) archive)))) + (setq package-archive-contents + (package--append-to-alist pkg-desc package-archive-contents))))) + +(defun package--append-to-alist (pkg-desc alist) + "Append an entry for PKG-DESC to the start of ALIST and return it. +This entry takes the form (`package-desc-name' PKG-DESC). + +If ALIST already has an entry with this name, destructively add +PKG-DESC to the cdr of this entry instead, sorted by version +number." + (let* ((name (package-desc-name pkg-desc)) + (priority-version (package-desc-priority-version pkg-desc)) + (existing-packages (assq name alist))) + (if (not existing-packages) + (cons (list name pkg-desc) + alist) + (while (if (and (cdr existing-packages) + (version-list-< priority-version + (package-desc-priority-version + (cadr existing-packages)))) + (setq existing-packages (cdr existing-packages)) + (push pkg-desc (cdr existing-packages)) + nil)) + alist))) (defun package-download-transaction (packages) "Download and install all the packages in PACKAGES. @@ -1188,30 +1298,74 @@ The return result is a `package-desc'." (unless tar-desc (error "No package descriptor file found")) (with-current-buffer (tar--extract tar-desc) - (goto-char (point-min)) (unwind-protect - (let* ((pkg-def-parsed (read (current-buffer))) - (pkg-desc - (if (not (eq (car pkg-def-parsed) 'define-package)) - (error "Can't find define-package in %s" - (tar-header-name tar-desc)) - (apply #'package-desc-from-define - (append (cdr pkg-def-parsed)))))) - (setf (package-desc-kind pkg-desc) 'tar) - pkg-desc) + (package--read-pkg-desc 'tar) (kill-buffer (current-buffer)))))) +(defun package-dir-info () + "Find package information for a directory. +The return result is a `package-desc'." + (cl-assert (derived-mode-p 'dired-mode)) + (let* ((desc-file (package--description-file default-directory))) + (if (file-readable-p desc-file) + (with-temp-buffer + (insert-file-contents desc-file) + (package--read-pkg-desc 'dir)) + (let ((files (directory-files default-directory t "\\.el\\'" t)) + info) + (while files + (with-temp-buffer + (insert-file-contents (pop files)) + ;; When we find the file with the data, + (when (setq info (ignore-errors (package-buffer-info))) + ;; stop looping, + (setq files nil) + ;; set the 'dir kind, + (setf (package-desc-kind info) 'dir)))) + ;; and return the info. + info)))) + +(defun package--read-pkg-desc (kind) + "Read a `define-package' form in current buffer. +Return the pkg-desc, with desc-kind set to KIND." + (goto-char (point-min)) + (unwind-protect + (let* ((pkg-def-parsed (read (current-buffer))) + (pkg-desc + (if (not (eq (car pkg-def-parsed) 'define-package)) + (error "Can't find define-package in %s" + (tar-header-name tar-desc)) + (apply #'package-desc-from-define + (append (cdr pkg-def-parsed)))))) + (setf (package-desc-kind pkg-desc) kind) + pkg-desc))) + ;;;###autoload (defun package-install-from-buffer () "Install a package from the current buffer. -The current buffer is assumed to be a single .el or .tar file that follows the -packaging guidelines; see info node `(elisp)Packaging'. +The current buffer is assumed to be a single .el or .tar file or +a directory. These must follow the packaging guidelines (see +info node `(elisp)Packaging'). + +Specially, if current buffer is a directory, the -pkg.el +description file is not mandatory, in which case the information +is derived from the main .el file in the directory. + Downloads and installs required packages as needed." (interactive) - (let ((pkg-desc (if (derived-mode-p 'tar-mode) - (package-tar-file-info) - (package-buffer-info)))) + (let ((pkg-desc + (cond + ((derived-mode-p 'dired-mode) + ;; This is the only way a package-desc object with a `dir' + ;; desc-kind can be created. Such packages can't be + ;; uploaded or installed from archives, they can only be + ;; installed from local buffers or directories. + (package-dir-info)) + ((derived-mode-p 'tar-mode) + (package-tar-file-info)) + (t + (package-buffer-info))))) ;; Download and install the dependencies. (let* ((requires (package-desc-reqs pkg-desc)) (transaction (package-compute-transaction nil requires))) @@ -1226,8 +1380,12 @@ Downloads and installs required packages as needed." The file can either be a tar file or an Emacs Lisp file." (interactive "fPackage file name: ") (with-temp-buffer - (insert-file-contents-literally file) - (when (string-match "\\.tar\\'" file) (tar-mode)) + (if (file-directory-p file) + (progn + (setq default-directory file) + (dired-mode)) + (insert-file-contents-literally file) + (when (string-match "\\.tar\\'" file) (tar-mode))) (package-install-from-buffer))) (defun package-delete (pkg-desc) @@ -1255,6 +1413,25 @@ The file can either be a tar file or an Emacs Lisp file." "Return the archive containing the package NAME." (cdr (assoc (package-desc-archive desc) package-archives))) +(defun package-archive-priority (archive) + "Return the priority of ARCHIVE. + +The archive priorities are specified in +`package-archive-priorities'. If not given there, the priority +defaults to 0." + (or (cdr (assoc archive package-archive-priorities)) + 0)) + +(defun package-desc-priority-version (pkg-desc) + "Return the version PKG-DESC with the archive priority prepended. + +This allows for easy comparison of package versions from +different archives if archive priorities are meant to be taken in +consideration." + (cons (package-archive-priority + (package-desc-archive pkg-desc)) + (package-desc-version pkg-desc))) + (defun package--download-one-archive (archive file) "Retrieve an archive file FILE from ARCHIVE, and cache it. ARCHIVE should be a cons cell of the form (NAME . LOCATION), @@ -1298,14 +1475,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)))) @@ -1932,18 +2104,18 @@ If optional arg BUTTON is non-nil, describe its associated package." ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC]) (let ((pkg-desc (car entry)) (status (aref (cadr entry) 2))) - (cond ((member status '("installed" "unsigned")) - (push pkg-desc installed)) - ((member status '("available" "new")) - (push (cons (package-desc-name pkg-desc) pkg-desc) - available))))) + (cond ((member status '("installed" "unsigned")) + (push pkg-desc installed)) + ((member status '("available" "new")) + (setq available (package--append-to-alist pkg-desc available)))))) ;; Loop through list of installed packages, finding upgrades. (dolist (pkg-desc installed) - (let ((avail-pkg (assq (package-desc-name pkg-desc) available))) - (and avail-pkg - (version-list-< (package-desc-version pkg-desc) - (package-desc-version (cdr avail-pkg))) - (push avail-pkg upgrades)))) + (let* ((name (package-desc-name pkg-desc)) + (avail-pkg (cadr (assq name available)))) + (and avail-pkg + (version-list-< (package-desc-priority-version pkg-desc) + (package-desc-priority-version avail-pkg)) + (push (cons name avail-pkg) upgrades)))) upgrades)) (defun package-menu-mark-upgrades () diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 7b845bf9adc..b495793bee0 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 180690c37bb..ac3cc74ca6a 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 7bd7deaf97b..b0fb23dbcc9 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..b28153b7f81 --- /dev/null +++ b/lisp/emacs-lisp/seq.el @@ -0,0 +1,273 @@ +;;; seq.el --- Sequence manipulation functions -*- lexical-binding: t -*- + +;; Copyright (C) 2014-2015 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 (errtext (format "Bad bounding indices: %s, %s" start end))) + (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)))))) + (when (> start 0) + (setq seq (nthcdr (1- start) seq)) + (or seq (error "%s" errtext)) + (setq seq (cdr seq))) + (if end + (let ((res nil)) + (while (and (>= (setq end (1- end)) start) seq) + (push (pop seq) res)) + (or (= (1+ end) start) (error "%s" errtext)) + (nreverse res)) + (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 184912d9fc4..5b9dc6422a2 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 f5083c4df94..78a6dc98456 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 933567db993..15a0914cb17 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 6875b76a99c..9ae11b71e5e 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) |